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