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 COMPOUND_EXPR.  */
1376
1377 tree
1378 build_compound_expr (tree result_type, tree stmt_operand, tree expr_operand)
1379 {
1380   bool addr_p = false;
1381   tree result;
1382
1383   /* If the result type is unconstrained, take the address of the operand and
1384      then dereference the result.  Likewise if the result type is passed by
1385      reference, but this is natively handled in the gimplifier.  */
1386   if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
1387       || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
1388     {
1389       result_type = build_pointer_type (result_type);
1390       expr_operand = build_unary_op (ADDR_EXPR, result_type, expr_operand);
1391       addr_p = true;
1392     }
1393
1394   result = fold_build2 (COMPOUND_EXPR, result_type, stmt_operand,
1395                         expr_operand);
1396
1397   if (addr_p)
1398     result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
1399
1400   return result;
1401 }
1402 /* Similar, but for RETURN_EXPR.  If RET_VAL is non-null, build a RETURN_EXPR
1403    around the assignment of RET_VAL to RET_OBJ.  Otherwise just build a bare
1404    RETURN_EXPR around RESULT_OBJ, which may be null in this case.  */
1405
1406 tree
1407 build_return_expr (tree ret_obj, tree ret_val)
1408 {
1409   tree result_expr;
1410
1411   if (ret_val)
1412     {
1413       /* The gimplifier explicitly enforces the following invariant:
1414
1415               RETURN_EXPR
1416                   |
1417               MODIFY_EXPR
1418               /        \
1419              /          \
1420          RET_OBJ        ...
1421
1422          As a consequence, type consistency dictates that we use the type
1423          of the RET_OBJ as the operation type.  */
1424       tree operation_type = TREE_TYPE (ret_obj);
1425
1426       /* Convert the right operand to the operation type.  Note that it's the
1427          same transformation as in the MODIFY_EXPR case of build_binary_op,
1428          with the assumption that the type cannot involve a placeholder.  */
1429       if (operation_type != TREE_TYPE (ret_val))
1430         ret_val = convert (operation_type, ret_val);
1431
1432       result_expr = build2 (MODIFY_EXPR, operation_type, ret_obj, ret_val);
1433     }
1434   else
1435     result_expr = ret_obj;
1436
1437   return build1 (RETURN_EXPR, void_type_node, result_expr);
1438 }
1439 \f
1440 /* Build a CALL_EXPR to call FUNDECL with one argument, ARG.  Return
1441    the CALL_EXPR.  */
1442
1443 tree
1444 build_call_1_expr (tree fundecl, tree arg)
1445 {
1446   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1447                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1448                                1, arg);
1449   TREE_SIDE_EFFECTS (call) = 1;
1450   return call;
1451 }
1452
1453 /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2.  Return
1454    the CALL_EXPR.  */
1455
1456 tree
1457 build_call_2_expr (tree fundecl, tree arg1, tree arg2)
1458 {
1459   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1460                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1461                                2, arg1, arg2);
1462   TREE_SIDE_EFFECTS (call) = 1;
1463   return call;
1464 }
1465
1466 /* Likewise to call FUNDECL with no arguments.  */
1467
1468 tree
1469 build_call_0_expr (tree fundecl)
1470 {
1471   /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS.  This makes
1472      it possible to propagate DECL_IS_PURE on parameterless functions.  */
1473   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1474                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1475                                0);
1476   return call;
1477 }
1478 \f
1479 /* Call a function that raises an exception and pass the line number and file
1480    name, if requested.  MSG says which exception function to call.
1481
1482    GNAT_NODE is the gnat node conveying the source location for which the
1483    error should be signaled, or Empty in which case the error is signaled on
1484    the current ref_file_name/input_line.
1485
1486    KIND says which kind of exception this is for
1487    (N_Raise_{Constraint,Storage,Program}_Error).  */
1488
1489 tree
1490 build_call_raise (int msg, Node_Id gnat_node, char kind)
1491 {
1492   tree fndecl = gnat_raise_decls[msg];
1493   tree label = get_exception_label (kind);
1494   tree filename;
1495   int line_number;
1496   const char *str;
1497   int len;
1498
1499   /* If this is to be done as a goto, handle that case.  */
1500   if (label)
1501     {
1502       Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
1503       tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
1504
1505       /* If Local_Raise is present, generate
1506          Local_Raise (exception'Identity);  */
1507       if (Present (local_raise))
1508         {
1509           tree gnu_local_raise
1510             = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
1511           tree gnu_exception_entity
1512             = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
1513           tree gnu_call
1514             = build_call_1_expr (gnu_local_raise,
1515                                  build_unary_op (ADDR_EXPR, NULL_TREE,
1516                                                  gnu_exception_entity));
1517
1518           gnu_result = build2 (COMPOUND_EXPR, void_type_node,
1519                                gnu_call, gnu_result);}
1520
1521       return gnu_result;
1522     }
1523
1524   str
1525     = (Debug_Flag_NN || Exception_Locations_Suppressed)
1526       ? ""
1527       : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1528         ? IDENTIFIER_POINTER
1529           (get_identifier (Get_Name_String
1530                            (Debug_Source_Name
1531                             (Get_Source_File_Index (Sloc (gnat_node))))))
1532         : ref_filename;
1533
1534   len = strlen (str);
1535   filename = build_string (len, str);
1536   line_number
1537     = (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1538       ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
1539
1540   TREE_TYPE (filename) = build_array_type (unsigned_char_type_node,
1541                                            build_index_type (size_int (len)));
1542
1543   return
1544     build_call_2_expr (fndecl,
1545                        build1 (ADDR_EXPR,
1546                                build_pointer_type (unsigned_char_type_node),
1547                                filename),
1548                        build_int_cst (NULL_TREE, line_number));
1549 }
1550
1551 /* Similar to build_call_raise, for an index or range check exception as
1552    determined by MSG, with extra information generated of the form
1553    "INDEX out of range FIRST..LAST".  */
1554
1555 tree
1556 build_call_raise_range (int msg, Node_Id gnat_node,
1557                         tree index, tree first, tree last)
1558 {
1559   tree call;
1560   tree fndecl = gnat_raise_decls_ext[msg];
1561   tree filename;
1562   int line_number, column_number;
1563   const char *str;
1564   int len;
1565
1566   str
1567     = (Debug_Flag_NN || Exception_Locations_Suppressed)
1568       ? ""
1569       : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1570         ? IDENTIFIER_POINTER
1571           (get_identifier (Get_Name_String
1572                            (Debug_Source_Name
1573                             (Get_Source_File_Index (Sloc (gnat_node))))))
1574         : ref_filename;
1575
1576   len = strlen (str);
1577   filename = build_string (len, str);
1578   if (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1579     {
1580       line_number = Get_Logical_Line_Number (Sloc (gnat_node));
1581       column_number = Get_Column_Number (Sloc (gnat_node));
1582     }
1583   else
1584     {
1585       line_number = input_line;
1586       column_number = 0;
1587     }
1588
1589   TREE_TYPE (filename) = build_array_type (unsigned_char_type_node,
1590                                            build_index_type (size_int (len)));
1591
1592   call = build_call_nary (TREE_TYPE (TREE_TYPE (fndecl)),
1593                           build_unary_op (ADDR_EXPR, NULL_TREE, fndecl),
1594                           6,
1595                           build1 (ADDR_EXPR,
1596                                   build_pointer_type (unsigned_char_type_node),
1597                                   filename),
1598                           build_int_cst (NULL_TREE, line_number),
1599                           build_int_cst (NULL_TREE, column_number),
1600                           convert (integer_type_node, index),
1601                           convert (integer_type_node, first),
1602                           convert (integer_type_node, last));
1603   TREE_SIDE_EFFECTS (call) = 1;
1604   return call;
1605 }
1606
1607 /* Similar to build_call_raise, with extra information about the column
1608    where the check failed.  */
1609
1610 tree
1611 build_call_raise_column (int msg, Node_Id gnat_node)
1612 {
1613   tree fndecl = gnat_raise_decls_ext[msg];
1614   tree call;
1615   tree filename;
1616   int line_number, column_number;
1617   const char *str;
1618   int len;
1619
1620   str
1621     = (Debug_Flag_NN || Exception_Locations_Suppressed)
1622       ? ""
1623       : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1624         ? IDENTIFIER_POINTER
1625           (get_identifier (Get_Name_String
1626                            (Debug_Source_Name
1627                             (Get_Source_File_Index (Sloc (gnat_node))))))
1628         : ref_filename;
1629
1630   len = strlen (str);
1631   filename = build_string (len, str);
1632   if (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1633     {
1634       line_number = Get_Logical_Line_Number (Sloc (gnat_node));
1635       column_number = Get_Column_Number (Sloc (gnat_node));
1636     }
1637   else
1638     {
1639       line_number = input_line;
1640       column_number = 0;
1641     }
1642
1643   TREE_TYPE (filename) = build_array_type (unsigned_char_type_node,
1644                                            build_index_type (size_int (len)));
1645
1646   call = build_call_nary (TREE_TYPE (TREE_TYPE (fndecl)),
1647                           build_unary_op (ADDR_EXPR, NULL_TREE, fndecl),
1648                           3,
1649                           build1 (ADDR_EXPR,
1650                                   build_pointer_type (unsigned_char_type_node),
1651                                   filename),
1652                           build_int_cst (NULL_TREE, line_number),
1653                           build_int_cst (NULL_TREE, column_number));
1654   TREE_SIDE_EFFECTS (call) = 1;
1655   return call;
1656 }
1657 \f
1658 /* qsort comparer for the bit positions of two constructor elements
1659    for record components.  */
1660
1661 static int
1662 compare_elmt_bitpos (const PTR rt1, const PTR rt2)
1663 {
1664   const constructor_elt * const elmt1 = (const constructor_elt const *) rt1;
1665   const constructor_elt * const elmt2 = (const constructor_elt const *) rt2;
1666   const_tree const field1 = elmt1->index;
1667   const_tree const field2 = elmt2->index;
1668   const int ret
1669     = tree_int_cst_compare (bit_position (field1), bit_position (field2));
1670
1671   return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
1672 }
1673
1674 /* Return a CONSTRUCTOR of TYPE whose elements are V.  */
1675
1676 tree
1677 gnat_build_constructor (tree type, VEC(constructor_elt,gc) *v)
1678 {
1679   bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
1680   bool side_effects = false;
1681   tree result, obj, val;
1682   unsigned int n_elmts;
1683
1684   /* Scan the elements to see if they are all constant or if any has side
1685      effects, to let us set global flags on the resulting constructor.  Count
1686      the elements along the way for possible sorting purposes below.  */
1687   FOR_EACH_CONSTRUCTOR_ELT (v, n_elmts, obj, val)
1688     {
1689       /* The predicate must be in keeping with output_constructor.  */
1690       if (!TREE_CONSTANT (val)
1691           || (TREE_CODE (type) == RECORD_TYPE
1692               && CONSTRUCTOR_BITFIELD_P (obj)
1693               && !initializer_constant_valid_for_bitfield_p (val))
1694           || !initializer_constant_valid_p (val, TREE_TYPE (val)))
1695         allconstant = false;
1696
1697       if (TREE_SIDE_EFFECTS (val))
1698         side_effects = true;
1699     }
1700
1701   /* For record types with constant components only, sort field list
1702      by increasing bit position.  This is necessary to ensure the
1703      constructor can be output as static data.  */
1704   if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
1705     VEC_qsort (constructor_elt, v, compare_elmt_bitpos);
1706
1707   result = build_constructor (type, v);
1708   TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant;
1709   TREE_SIDE_EFFECTS (result) = side_effects;
1710   TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
1711   return result;
1712 }
1713 \f
1714 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
1715    an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
1716    for the field.  Don't fold the result if NO_FOLD_P is true.
1717
1718    We also handle the fact that we might have been passed a pointer to the
1719    actual record and know how to look for fields in variant parts.  */
1720
1721 static tree
1722 build_simple_component_ref (tree record_variable, tree component,
1723                             tree field, bool no_fold_p)
1724 {
1725   tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
1726   tree ref, inner_variable;
1727
1728   gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE
1729                || TREE_CODE (record_type) == UNION_TYPE
1730                || TREE_CODE (record_type) == QUAL_UNION_TYPE)
1731               && TYPE_SIZE (record_type)
1732               && (component != 0) != (field != 0));
1733
1734   /* If no field was specified, look for a field with the specified name
1735      in the current record only.  */
1736   if (!field)
1737     for (field = TYPE_FIELDS (record_type); field;
1738          field = TREE_CHAIN (field))
1739       if (DECL_NAME (field) == component)
1740         break;
1741
1742   if (!field)
1743     return NULL_TREE;
1744
1745   /* If this field is not in the specified record, see if we can find a field
1746      in the specified record whose original field is the same as this one.  */
1747   if (DECL_CONTEXT (field) != record_type)
1748     {
1749       tree new_field;
1750
1751       /* First loop thru normal components.  */
1752       for (new_field = TYPE_FIELDS (record_type); new_field;
1753            new_field = DECL_CHAIN (new_field))
1754         if (SAME_FIELD_P (field, new_field))
1755           break;
1756
1757       /* Next, see if we're looking for an inherited component in an extension.
1758          If so, look thru the extension directly.  */
1759       if (!new_field
1760           && TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
1761           && TYPE_ALIGN_OK (record_type)
1762           && TREE_CODE (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
1763              == RECORD_TYPE
1764           && TYPE_ALIGN_OK (TREE_TYPE (TREE_OPERAND (record_variable, 0))))
1765         {
1766           ref = build_simple_component_ref (TREE_OPERAND (record_variable, 0),
1767                                             NULL_TREE, field, no_fold_p);
1768           if (ref)
1769             return ref;
1770         }
1771
1772       /* Next, loop thru DECL_INTERNAL_P components if we haven't found
1773          the component in the first search. Doing this search in 2 steps
1774          is required to avoiding hidden homonymous fields in the
1775          _Parent field.  */
1776       if (!new_field)
1777         for (new_field = TYPE_FIELDS (record_type); new_field;
1778              new_field = DECL_CHAIN (new_field))
1779           if (DECL_INTERNAL_P (new_field))
1780             {
1781               tree field_ref
1782                 = build_simple_component_ref (record_variable,
1783                                               NULL_TREE, new_field, no_fold_p);
1784               ref = build_simple_component_ref (field_ref, NULL_TREE, field,
1785                                                 no_fold_p);
1786
1787               if (ref)
1788                 return ref;
1789             }
1790
1791       field = new_field;
1792     }
1793
1794   if (!field)
1795     return NULL_TREE;
1796
1797   /* If the field's offset has overflowed, do not attempt to access it
1798      as doing so may trigger sanity checks deeper in the back-end.
1799      Note that we don't need to warn since this will be done on trying
1800      to declare the object.  */
1801   if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST
1802       && TREE_OVERFLOW (DECL_FIELD_OFFSET (field)))
1803     return NULL_TREE;
1804
1805   /* Look through conversion between type variants.  Note that this
1806      is transparent as far as the field is concerned.  */
1807   if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
1808       && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
1809          == record_type)
1810     inner_variable = TREE_OPERAND (record_variable, 0);
1811   else
1812     inner_variable = record_variable;
1813
1814   ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field,
1815                 NULL_TREE);
1816
1817   if (TREE_READONLY (record_variable) || TREE_READONLY (field))
1818     TREE_READONLY (ref) = 1;
1819   if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
1820       || TYPE_VOLATILE (record_type))
1821     TREE_THIS_VOLATILE (ref) = 1;
1822
1823   if (no_fold_p)
1824     return ref;
1825
1826   /* The generic folder may punt in this case because the inner array type
1827      can be self-referential, but folding is in fact not problematic.  */
1828   else if (TREE_CODE (record_variable) == CONSTRUCTOR
1829            && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable)))
1830     {
1831       VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable);
1832       unsigned HOST_WIDE_INT idx;
1833       tree index, value;
1834       FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
1835         if (index == field)
1836           return value;
1837       return ref;
1838     }
1839
1840   else
1841     return fold (ref);
1842 }
1843 \f
1844 /* Like build_simple_component_ref, except that we give an error if the
1845    reference could not be found.  */
1846
1847 tree
1848 build_component_ref (tree record_variable, tree component,
1849                      tree field, bool no_fold_p)
1850 {
1851   tree ref = build_simple_component_ref (record_variable, component, field,
1852                                          no_fold_p);
1853
1854   if (ref)
1855     return ref;
1856
1857   /* If FIELD was specified, assume this is an invalid user field so raise
1858      Constraint_Error.  Otherwise, we have no type to return so abort.  */
1859   gcc_assert (field);
1860   return build1 (NULL_EXPR, TREE_TYPE (field),
1861                  build_call_raise (CE_Discriminant_Check_Failed, Empty,
1862                                    N_Raise_Constraint_Error));
1863 }
1864 \f
1865 /* Helper for build_call_alloc_dealloc, with arguments to be interpreted
1866    identically.  Process the case where a GNAT_PROC to call is provided.  */
1867
1868 static inline tree
1869 build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
1870                                Entity_Id gnat_proc, Entity_Id gnat_pool)
1871 {
1872   tree gnu_proc = gnat_to_gnu (gnat_proc);
1873   tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
1874   tree gnu_call;
1875
1876   /* The storage pools are obviously always tagged types, but the
1877      secondary stack uses the same mechanism and is not tagged.  */
1878   if (Is_Tagged_Type (Etype (gnat_pool)))
1879     {
1880       /* The size is the third parameter; the alignment is the
1881          same type.  */
1882       Entity_Id gnat_size_type
1883         = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
1884       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1885
1886       tree gnu_pool = gnat_to_gnu (gnat_pool);
1887       tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
1888       tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
1889
1890       gnu_size = convert (gnu_size_type, gnu_size);
1891       gnu_align = convert (gnu_size_type, gnu_align);
1892
1893       /* The first arg is always the address of the storage pool; next
1894          comes the address of the object, for a deallocator, then the
1895          size and alignment.  */
1896       if (gnu_obj)
1897         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1898                                     gnu_proc_addr, 4, gnu_pool_addr,
1899                                     gnu_obj, gnu_size, gnu_align);
1900       else
1901         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1902                                     gnu_proc_addr, 3, gnu_pool_addr,
1903                                     gnu_size, gnu_align);
1904     }
1905
1906   /* Secondary stack case.  */
1907   else
1908     {
1909       /* The size is the second parameter.  */
1910       Entity_Id gnat_size_type
1911         = Etype (Next_Formal (First_Formal (gnat_proc)));
1912       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1913
1914       gnu_size = convert (gnu_size_type, gnu_size);
1915
1916       /* The first arg is the address of the object, for a deallocator,
1917          then the size.  */
1918       if (gnu_obj)
1919         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1920                                     gnu_proc_addr, 2, gnu_obj, gnu_size);
1921       else
1922         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1923                                     gnu_proc_addr, 1, gnu_size);
1924     }
1925
1926   TREE_SIDE_EFFECTS (gnu_call) = 1;
1927   return gnu_call;
1928 }
1929
1930 /* Helper for build_call_alloc_dealloc, to build and return an allocator for
1931    DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default
1932    __gnat_malloc allocator.  Honor DATA_TYPE alignments greater than what the
1933    latter offers.  */
1934
1935 static inline tree
1936 maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
1937 {
1938   /* When the DATA_TYPE alignment is stricter than what malloc offers
1939      (super-aligned case), we allocate an "aligning" wrapper type and return
1940      the address of its single data field with the malloc's return value
1941      stored just in front.  */
1942
1943   unsigned int data_align = TYPE_ALIGN (data_type);
1944   unsigned int default_allocator_alignment
1945       = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1946
1947   tree aligning_type
1948     = ((data_align > default_allocator_alignment)
1949        ? make_aligning_type (data_type, data_align, data_size,
1950                              default_allocator_alignment,
1951                              POINTER_SIZE / BITS_PER_UNIT)
1952        : NULL_TREE);
1953
1954   tree size_to_malloc
1955     = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
1956
1957   tree malloc_ptr;
1958
1959   /* On VMS, if pointers are 64-bit and the allocator size is 32-bit or
1960      Convention C, allocate 32-bit memory.  */
1961   if (TARGET_ABI_OPEN_VMS
1962       && POINTER_SIZE == 64
1963       && Nkind (gnat_node) == N_Allocator
1964       && (UI_To_Int (Esize (Etype (gnat_node))) == 32
1965           || Convention (Etype (gnat_node)) == Convention_C))
1966     malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc);
1967   else
1968     malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc);
1969
1970   if (aligning_type)
1971     {
1972       /* Latch malloc's return value and get a pointer to the aligning field
1973          first.  */
1974       tree storage_ptr = gnat_protect_expr (malloc_ptr);
1975
1976       tree aligning_record_addr
1977         = convert (build_pointer_type (aligning_type), storage_ptr);
1978
1979       tree aligning_record
1980         = build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr);
1981
1982       tree aligning_field
1983         = build_component_ref (aligning_record, NULL_TREE,
1984                                TYPE_FIELDS (aligning_type), false);
1985
1986       tree aligning_field_addr
1987         = build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
1988
1989       /* Then arrange to store the allocator's return value ahead
1990          and return.  */
1991       tree storage_ptr_slot_addr
1992         = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1993                            convert (ptr_void_type_node, aligning_field_addr),
1994                            size_int (-(HOST_WIDE_INT) POINTER_SIZE
1995                                      / BITS_PER_UNIT));
1996
1997       tree storage_ptr_slot
1998         = build_unary_op (INDIRECT_REF, NULL_TREE,
1999                           convert (build_pointer_type (ptr_void_type_node),
2000                                    storage_ptr_slot_addr));
2001
2002       return
2003         build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr),
2004                 build_binary_op (MODIFY_EXPR, NULL_TREE,
2005                                  storage_ptr_slot, storage_ptr),
2006                 aligning_field_addr);
2007     }
2008   else
2009     return malloc_ptr;
2010 }
2011
2012 /* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object
2013    designated by DATA_PTR using the __gnat_free entry point.  */
2014
2015 static inline tree
2016 maybe_wrap_free (tree data_ptr, tree data_type)
2017 {
2018   /* In the regular alignment case, we pass the data pointer straight to free.
2019      In the superaligned case, we need to retrieve the initial allocator
2020      return value, stored in front of the data block at allocation time.  */
2021
2022   unsigned int data_align = TYPE_ALIGN (data_type);
2023   unsigned int default_allocator_alignment
2024       = get_target_default_allocator_alignment () * BITS_PER_UNIT;
2025
2026   tree free_ptr;
2027
2028   if (data_align > default_allocator_alignment)
2029     {
2030       /* DATA_FRONT_PTR (void *)
2031          = (void *)DATA_PTR - (void *)sizeof (void *))  */
2032       tree data_front_ptr
2033         = build_binary_op
2034           (POINTER_PLUS_EXPR, ptr_void_type_node,
2035            convert (ptr_void_type_node, data_ptr),
2036            size_int (-(HOST_WIDE_INT) POINTER_SIZE / BITS_PER_UNIT));
2037
2038       /* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR  */
2039       free_ptr
2040         = build_unary_op
2041           (INDIRECT_REF, NULL_TREE,
2042            convert (build_pointer_type (ptr_void_type_node), data_front_ptr));
2043     }
2044   else
2045     free_ptr = data_ptr;
2046
2047   return build_call_1_expr (free_decl, free_ptr);
2048 }
2049
2050 /* Build a GCC tree to call an allocation or deallocation function.
2051    If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
2052    generate an allocator.
2053
2054    GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
2055    object type, used to determine the to-be-honored address alignment.
2056    GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
2057    pool to use.  If not present, malloc and free are used.  GNAT_NODE is used
2058    to provide an error location for restriction violation messages.  */
2059
2060 tree
2061 build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
2062                           Entity_Id gnat_proc, Entity_Id gnat_pool,
2063                           Node_Id gnat_node)
2064 {
2065   gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
2066
2067   /* Explicit proc to call ?  This one is assumed to deal with the type
2068      alignment constraints.  */
2069   if (Present (gnat_proc))
2070     return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type,
2071                                           gnat_proc, gnat_pool);
2072
2073   /* Otherwise, object to "free" or "malloc" with possible special processing
2074      for alignments stricter than what the default allocator honors.  */
2075   else if (gnu_obj)
2076     return maybe_wrap_free (gnu_obj, gnu_type);
2077   else
2078     {
2079       /* Assert that we no longer can be called with this special pool.  */
2080       gcc_assert (gnat_pool != -1);
2081
2082       /* Check that we aren't violating the associated restriction.  */
2083       if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
2084         Check_No_Implicit_Heap_Alloc (gnat_node);
2085
2086       return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
2087     }
2088 }
2089 \f
2090 /* Build a GCC tree to correspond to allocating an object of TYPE whose
2091    initial value is INIT, if INIT is nonzero.  Convert the expression to
2092    RESULT_TYPE, which must be some type of pointer.  Return the tree.
2093
2094    GNAT_PROC and GNAT_POOL optionally give the procedure to call and
2095    the storage pool to use.  GNAT_NODE is used to provide an error
2096    location for restriction violation messages.  If IGNORE_INIT_TYPE is
2097    true, ignore the type of INIT for the purpose of determining the size;
2098    this will cause the maximum size to be allocated if TYPE is of
2099    self-referential size.  */
2100
2101 tree
2102 build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
2103                  Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
2104 {
2105   tree size = TYPE_SIZE_UNIT (type);
2106   tree result;
2107
2108   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
2109   if (init && TREE_CODE (init) == NULL_EXPR)
2110     return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0));
2111
2112   /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
2113      sizes of the object and its template.  Allocate the whole thing and
2114      fill in the parts that are known.  */
2115   else if (TYPE_IS_FAT_OR_THIN_POINTER_P (result_type))
2116     {
2117       tree storage_type
2118         = build_unc_object_type_from_ptr (result_type, type,
2119                                           get_identifier ("ALLOC"), false);
2120       tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
2121       tree storage_ptr_type = build_pointer_type (storage_type);
2122       tree storage;
2123
2124       size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
2125                                              init);
2126
2127       /* If the size overflows, pass -1 so the allocator will raise
2128          storage error.  */
2129       if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
2130         size = ssize_int (-1);
2131
2132       storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type,
2133                                           gnat_proc, gnat_pool, gnat_node);
2134       storage = convert (storage_ptr_type, gnat_protect_expr (storage));
2135
2136       if (TYPE_IS_PADDING_P (type))
2137         {
2138           type = TREE_TYPE (TYPE_FIELDS (type));
2139           if (init)
2140             init = convert (type, init);
2141         }
2142
2143       /* If there is an initializing expression, make a constructor for
2144          the entire object including the bounds and copy it into the
2145          object.  If there is no initializing expression, just set the
2146          bounds.  */
2147       if (init)
2148         {
2149           VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
2150
2151           CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (storage_type),
2152                                   build_template (template_type, type, init));
2153           CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (storage_type)),
2154                                   init);
2155
2156           return convert
2157             (result_type,
2158              build2 (COMPOUND_EXPR, storage_ptr_type,
2159                      build_binary_op
2160                      (MODIFY_EXPR, storage_type,
2161                       build_unary_op (INDIRECT_REF, NULL_TREE,
2162                                       convert (storage_ptr_type, storage)),
2163                       gnat_build_constructor (storage_type, v)),
2164                      convert (storage_ptr_type, storage)));
2165         }
2166       else
2167         return build2
2168           (COMPOUND_EXPR, result_type,
2169            build_binary_op
2170            (MODIFY_EXPR, template_type,
2171             build_component_ref
2172             (build_unary_op (INDIRECT_REF, NULL_TREE,
2173                              convert (storage_ptr_type, storage)),
2174              NULL_TREE, TYPE_FIELDS (storage_type), false),
2175             build_template (template_type, type, NULL_TREE)),
2176            convert (result_type, convert (storage_ptr_type, storage)));
2177     }
2178
2179   /* If we have an initializing expression, see if its size is simpler
2180      than the size from the type.  */
2181   if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init))
2182       && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
2183           || CONTAINS_PLACEHOLDER_P (size)))
2184     size = TYPE_SIZE_UNIT (TREE_TYPE (init));
2185
2186   /* If the size is still self-referential, reference the initializing
2187      expression, if it is present.  If not, this must have been a
2188      call to allocate a library-level object, in which case we use
2189      the maximum size.  */
2190   if (CONTAINS_PLACEHOLDER_P (size))
2191     {
2192       if (!ignore_init_type && init)
2193         size = substitute_placeholder_in_expr (size, init);
2194       else
2195         size = max_size (size, true);
2196     }
2197
2198   /* If the size overflows, pass -1 so the allocator will raise
2199      storage error.  */
2200   if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
2201     size = ssize_int (-1);
2202
2203   result = convert (result_type,
2204                     build_call_alloc_dealloc (NULL_TREE, size, type,
2205                                               gnat_proc, gnat_pool,
2206                                               gnat_node));
2207
2208   /* If we have an initial value, protect the new address, assign the value
2209      and return the address with a COMPOUND_EXPR.  */
2210   if (init)
2211     {
2212       result = gnat_protect_expr (result);
2213       result
2214         = build2 (COMPOUND_EXPR, TREE_TYPE (result),
2215                   build_binary_op
2216                   (MODIFY_EXPR, NULL_TREE,
2217                    build_unary_op (INDIRECT_REF,
2218                                    TREE_TYPE (TREE_TYPE (result)), result),
2219                    init),
2220                   result);
2221     }
2222
2223   return convert (result_type, result);
2224 }
2225 \f
2226 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
2227    GNAT_FORMAL is how we find the descriptor record.  GNAT_ACTUAL is
2228    how we derive the source location to raise C_E on an out of range
2229    pointer. */
2230
2231 tree
2232 fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
2233 {
2234   tree parm_decl = get_gnu_tree (gnat_formal);
2235   tree record_type = TREE_TYPE (TREE_TYPE (parm_decl));
2236   tree field;
2237   const bool do_range_check
2238     = strcmp ("MBO",
2239               IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type))));
2240   VEC(constructor_elt,gc) *v = NULL;
2241
2242   expr = maybe_unconstrained_array (expr);
2243   gnat_mark_addressable (expr);
2244
2245   for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
2246     {
2247       tree conexpr = convert (TREE_TYPE (field),
2248                               SUBSTITUTE_PLACEHOLDER_IN_EXPR
2249                               (DECL_INITIAL (field), expr));
2250
2251       /* Check to ensure that only 32-bit pointers are passed in
2252          32-bit descriptors */
2253       if (do_range_check
2254           && strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0)
2255         {
2256           tree pointer64type
2257             = build_pointer_type_for_mode (void_type_node, DImode, false);
2258           tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr);
2259           tree malloc64low
2260             = build_int_cstu (long_integer_type_node, 0x80000000);
2261
2262           add_stmt (build3 (COND_EXPR, void_type_node,
2263                             build_binary_op (GE_EXPR, boolean_type_node,
2264                                              convert (long_integer_type_node,
2265                                                       addr64expr),
2266                                              malloc64low),
2267                             build_call_raise (CE_Range_Check_Failed,
2268                                               gnat_actual,
2269                                               N_Raise_Constraint_Error),
2270                             NULL_TREE));
2271         }
2272       CONSTRUCTOR_APPEND_ELT (v, field, conexpr);
2273     }
2274
2275   return gnat_build_constructor (record_type, v);
2276 }
2277
2278 /* Indicate that we need to take the address of T and that it therefore
2279    should not be allocated in a register.  Returns true if successful.  */
2280
2281 bool
2282 gnat_mark_addressable (tree t)
2283 {
2284   while (true)
2285     switch (TREE_CODE (t))
2286       {
2287       case ADDR_EXPR:
2288       case COMPONENT_REF:
2289       case ARRAY_REF:
2290       case ARRAY_RANGE_REF:
2291       case REALPART_EXPR:
2292       case IMAGPART_EXPR:
2293       case VIEW_CONVERT_EXPR:
2294       case NON_LVALUE_EXPR:
2295       CASE_CONVERT:
2296         t = TREE_OPERAND (t, 0);
2297         break;
2298
2299       case COMPOUND_EXPR:
2300         t = TREE_OPERAND (t, 1);
2301         break;
2302
2303       case CONSTRUCTOR:
2304         TREE_ADDRESSABLE (t) = 1;
2305         return true;
2306
2307       case VAR_DECL:
2308       case PARM_DECL:
2309       case RESULT_DECL:
2310         TREE_ADDRESSABLE (t) = 1;
2311         return true;
2312
2313       case FUNCTION_DECL:
2314         TREE_ADDRESSABLE (t) = 1;
2315         return true;
2316
2317       case CONST_DECL:
2318         return DECL_CONST_CORRESPONDING_VAR (t)
2319                && gnat_mark_addressable (DECL_CONST_CORRESPONDING_VAR (t));
2320
2321       default:
2322         return true;
2323     }
2324 }
2325 \f
2326 /* Save EXP for later use or reuse.  This is equivalent to save_expr in tree.c
2327    but we know how to handle our own nodes.  */
2328
2329 tree
2330 gnat_save_expr (tree exp)
2331 {
2332   tree type = TREE_TYPE (exp);
2333   enum tree_code code = TREE_CODE (exp);
2334
2335   if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR)
2336     return exp;
2337
2338   if (code == UNCONSTRAINED_ARRAY_REF)
2339     {
2340       tree t = build1 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)));
2341       TREE_READONLY (t) = TYPE_READONLY (type);
2342       return t;
2343     }
2344
2345   /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
2346      This may be more efficient, but will also allow us to more easily find
2347      the match for the PLACEHOLDER_EXPR.  */
2348   if (code == COMPONENT_REF
2349       && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
2350     return build3 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)),
2351                    TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
2352
2353   return save_expr (exp);
2354 }
2355
2356 /* Protect EXP for immediate reuse.  This is a variant of gnat_save_expr that
2357    is optimized under the assumption that EXP's value doesn't change before
2358    its subsequent reuse(s) except through its potential reevaluation.  */
2359
2360 tree
2361 gnat_protect_expr (tree exp)
2362 {
2363   tree type = TREE_TYPE (exp);
2364   enum tree_code code = TREE_CODE (exp);
2365
2366   if (TREE_CONSTANT (exp) || code == SAVE_EXPR || code == NULL_EXPR)
2367     return exp;
2368
2369   /* If EXP has no side effects, we theoritically don't need to do anything.
2370      However, we may be recursively passed more and more complex expressions
2371      involving checks which will be reused multiple times and eventually be
2372      unshared for gimplification; in order to avoid a complexity explosion
2373      at that point, we protect any expressions more complex than a simple
2374      arithmetic expression.  */
2375   if (!TREE_SIDE_EFFECTS (exp))
2376     {
2377       tree inner = skip_simple_arithmetic (exp);
2378       if (!EXPR_P (inner) || REFERENCE_CLASS_P (inner))
2379         return exp;
2380     }
2381
2382   /* If this is a conversion, protect what's inside the conversion.  */
2383   if (code == NON_LVALUE_EXPR
2384       || CONVERT_EXPR_CODE_P (code)
2385       || code == VIEW_CONVERT_EXPR)
2386   return build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
2387
2388   /* If we're indirectly referencing something, we only need to protect the
2389      address since the data itself can't change in these situations.  */
2390   if (code == INDIRECT_REF || code == UNCONSTRAINED_ARRAY_REF)
2391     {
2392       tree t = build1 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)));
2393       TREE_READONLY (t) = TYPE_READONLY (type);
2394       return t;
2395     }
2396
2397   /* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
2398      This may be more efficient, but will also allow us to more easily find
2399      the match for the PLACEHOLDER_EXPR.  */
2400   if (code == COMPONENT_REF
2401       && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
2402     return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)),
2403                    TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
2404
2405   /* If this is a fat pointer or something that can be placed in a register,
2406      just make a SAVE_EXPR.  Likewise for a CALL_EXPR as large objects are
2407      returned via invisible reference in most ABIs so the temporary will
2408      directly be filled by the callee.  */
2409   if (TYPE_IS_FAT_POINTER_P (type)
2410       || TYPE_MODE (type) != BLKmode
2411       || code == CALL_EXPR)
2412     return save_expr (exp);
2413
2414   /* Otherwise reference, protect the address and dereference.  */
2415   return
2416     build_unary_op (INDIRECT_REF, type,
2417                     save_expr (build_unary_op (ADDR_EXPR,
2418                                                build_reference_type (type),
2419                                                exp)));
2420 }
2421
2422 /* This is equivalent to stabilize_reference_1 in tree.c but we take an extra
2423    argument to force evaluation of everything.  */
2424
2425 static tree
2426 gnat_stabilize_reference_1 (tree e, bool force)
2427 {
2428   enum tree_code code = TREE_CODE (e);
2429   tree type = TREE_TYPE (e);
2430   tree result;
2431
2432   /* We cannot ignore const expressions because it might be a reference
2433      to a const array but whose index contains side-effects.  But we can
2434      ignore things that are actual constant or that already have been
2435      handled by this function.  */
2436   if (TREE_CONSTANT (e) || code == SAVE_EXPR)
2437     return e;
2438
2439   switch (TREE_CODE_CLASS (code))
2440     {
2441     case tcc_exceptional:
2442     case tcc_declaration:
2443     case tcc_comparison:
2444     case tcc_expression:
2445     case tcc_reference:
2446     case tcc_vl_exp:
2447       /* If this is a COMPONENT_REF of a fat pointer, save the entire
2448          fat pointer.  This may be more efficient, but will also allow
2449          us to more easily find the match for the PLACEHOLDER_EXPR.  */
2450       if (code == COMPONENT_REF
2451           && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
2452         result
2453           = build3 (code, type,
2454                     gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
2455                     TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
2456       /* If the expression has side-effects, then encase it in a SAVE_EXPR
2457          so that it will only be evaluated once.  */
2458       /* The tcc_reference and tcc_comparison classes could be handled as
2459          below, but it is generally faster to only evaluate them once.  */
2460       else if (TREE_SIDE_EFFECTS (e) || force)
2461         return save_expr (e);
2462       else
2463         return e;
2464       break;
2465
2466     case tcc_binary:
2467       /* Recursively stabilize each operand.  */
2468       result
2469         = build2 (code, type,
2470                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
2471                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force));
2472       break;
2473
2474     case tcc_unary:
2475       /* Recursively stabilize each operand.  */
2476       result
2477         = build1 (code, type,
2478                   gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force));
2479       break;
2480
2481     default:
2482       gcc_unreachable ();
2483     }
2484
2485   /* See similar handling in gnat_stabilize_reference.  */
2486   TREE_READONLY (result) = TREE_READONLY (e);
2487   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
2488   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
2489
2490   if (code == INDIRECT_REF || code == ARRAY_REF || code == ARRAY_RANGE_REF)
2491     TREE_THIS_NOTRAP (result) = TREE_THIS_NOTRAP (e);
2492
2493   return result;
2494 }
2495
2496 /* This is equivalent to stabilize_reference in tree.c but we know how to
2497    handle our own nodes and we take extra arguments.  FORCE says whether to
2498    force evaluation of everything.  We set SUCCESS to true unless we walk
2499    through something we don't know how to stabilize.  */
2500
2501 tree
2502 gnat_stabilize_reference (tree ref, bool force, bool *success)
2503 {
2504   tree type = TREE_TYPE (ref);
2505   enum tree_code code = TREE_CODE (ref);
2506   tree result;
2507
2508   /* Assume we'll success unless proven otherwise.  */
2509   if (success)
2510     *success = true;
2511
2512   switch (code)
2513     {
2514     case CONST_DECL:
2515     case VAR_DECL:
2516     case PARM_DECL:
2517     case RESULT_DECL:
2518       /* No action is needed in this case.  */
2519       return ref;
2520
2521     case ADDR_EXPR:
2522     CASE_CONVERT:
2523     case FLOAT_EXPR:
2524     case FIX_TRUNC_EXPR:
2525     case VIEW_CONVERT_EXPR:
2526       result
2527         = build1 (code, type,
2528                   gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2529                                             success));
2530       break;
2531
2532     case INDIRECT_REF:
2533     case UNCONSTRAINED_ARRAY_REF:
2534       result = build1 (code, type,
2535                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
2536                                                    force));
2537       break;
2538
2539     case COMPONENT_REF:
2540      result = build3 (COMPONENT_REF, type,
2541                       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2542                                                 success),
2543                       TREE_OPERAND (ref, 1), NULL_TREE);
2544       break;
2545
2546     case BIT_FIELD_REF:
2547       result = build3 (BIT_FIELD_REF, type,
2548                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2549                                                  success),
2550                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2551                                                    force),
2552                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
2553                                                    force));
2554       break;
2555
2556     case ARRAY_REF:
2557     case ARRAY_RANGE_REF:
2558       result = build4 (code, type,
2559                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2560                                                  success),
2561                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2562                                                    force),
2563                        NULL_TREE, NULL_TREE);
2564       break;
2565
2566     case CALL_EXPR:
2567       result = gnat_stabilize_reference_1 (ref, force);
2568       break;
2569
2570     case COMPOUND_EXPR:
2571       result = build2 (COMPOUND_EXPR, type,
2572                        gnat_stabilize_reference (TREE_OPERAND (ref, 0), force,
2573                                                  success),
2574                        gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
2575                                                    force));
2576       break;
2577
2578     case CONSTRUCTOR:
2579       /* Constructors with 1 element are used extensively to formally
2580          convert objects to special wrapping types.  */
2581       if (TREE_CODE (type) == RECORD_TYPE
2582           && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1)
2583         {
2584           tree index
2585             = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index;
2586           tree value
2587             = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value;
2588           result
2589             = build_constructor_single (type, index,
2590                                         gnat_stabilize_reference_1 (value,
2591                                                                     force));
2592         }
2593       else
2594         {
2595           if (success)
2596             *success = false;
2597           return ref;
2598         }
2599       break;
2600
2601     case ERROR_MARK:
2602       ref = error_mark_node;
2603
2604       /* ...  fall through to failure ... */
2605
2606       /* If arg isn't a kind of lvalue we recognize, make no change.
2607          Caller should recognize the error for an invalid lvalue.  */
2608     default:
2609       if (success)
2610         *success = false;
2611       return ref;
2612     }
2613
2614   /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression
2615      may not be sustained across some paths, such as the way via build1 for
2616      INDIRECT_REF.  We reset those flags here in the general case, which is
2617      consistent with the GCC version of this routine.
2618
2619      Special care should be taken regarding TREE_SIDE_EFFECTS, because some
2620      paths introduce side-effects where there was none initially (e.g. if a
2621      SAVE_EXPR is built) and we also want to keep track of that.  */
2622   TREE_READONLY (result) = TREE_READONLY (ref);
2623   TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
2624   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
2625
2626   return result;
2627 }