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