gcc/ada/gcc-interface/utils2.c

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