gcc/ada/gcc-interface/utils2.c

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