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