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