gcc/ada/gcc-interface/utils2.c

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