gcc/ada/gcc-interface/utils2.c

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