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-2009, 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 MODIFY_EXPR:
 613       /* If there were integral or pointer conversions on the LHS, remove
 614          them; we'll be putting them back below if needed.  Likewise for
 615          conversions between array and record types, except for justified
 616          modular types.  But don't do this if the right operand is not
 617          BLKmode (for packed arrays) unless we are not changing the mode.  */
 618       while ((CONVERT_EXPR_P (left_operand)
 619               || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
 620              && (((INTEGRAL_TYPE_P (left_type)
 621                    || POINTER_TYPE_P (left_type))
 622                   && (INTEGRAL_TYPE_P (TREE_TYPE
 623                                        (TREE_OPERAND (left_operand, 0)))
 624                       || POINTER_TYPE_P (TREE_TYPE
 625                                          (TREE_OPERAND (left_operand, 0)))))
 626                  || (((TREE_CODE (left_type) == RECORD_TYPE
 627                        && !TYPE_JUSTIFIED_MODULAR_P (left_type))
 628                       || TREE_CODE (left_type) == ARRAY_TYPE)
 629                      && ((TREE_CODE (TREE_TYPE
 630                                      (TREE_OPERAND (left_operand, 0)))
 631                           == RECORD_TYPE)
 632                          || (TREE_CODE (TREE_TYPE
 633                                         (TREE_OPERAND (left_operand, 0)))
 634                              == ARRAY_TYPE))
 635                      && (TYPE_MODE (right_type) == BLKmode
 636                          || (TYPE_MODE (left_type)
 637                              == TYPE_MODE (TREE_TYPE
 638                                            (TREE_OPERAND
 639                                             (left_operand, 0))))))))
 640         {
 641           left_operand = TREE_OPERAND (left_operand, 0);
 642           left_type = TREE_TYPE (left_operand);
 643         }
 644
 645       /* If a class-wide type may be involved, force use of the RHS type.  */
 646       if ((TREE_CODE (right_type) == RECORD_TYPE
 647            || TREE_CODE (right_type) == UNION_TYPE)
 648           && TYPE_ALIGN_OK (right_type))
 649         operation_type = right_type;
 650
 651       /* If we are copying between padded objects with compatible types, use
 652          the padded view of the objects, this is very likely more efficient.
 653          Likewise for a padded object that is assigned a constructor, if we
 654          can convert the constructor to the inner type, to avoid putting a
 655          VIEW_CONVERT_EXPR on the LHS.  But don't do so if we wouldn't have
 656          actually copied anything.  */
 657       else if (TYPE_IS_PADDING_P (left_type)
 658                && TREE_CONSTANT (TYPE_SIZE (left_type))
 659                && ((TREE_CODE (right_operand) == COMPONENT_REF
 660                     && TYPE_IS_PADDING_P
 661                        (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
 662                     && gnat_types_compatible_p
 663                        (left_type,
 664                         TREE_TYPE (TREE_OPERAND (right_operand, 0))))
 665                    || (TREE_CODE (right_operand) == CONSTRUCTOR
 666                        && !CONTAINS_PLACEHOLDER_P
 667                            (DECL_SIZE (TYPE_FIELDS (left_type)))))
 668                && !integer_zerop (TYPE_SIZE (right_type)))
 669         operation_type = left_type;
 670
 671       /* Find the best type to use for copying between aggregate types.  */
 672       else if (((TREE_CODE (left_type) == ARRAY_TYPE
 673                  && TREE_CODE (right_type) == ARRAY_TYPE)
 674                 || (TREE_CODE (left_type) == RECORD_TYPE
 675                     && TREE_CODE (right_type) == RECORD_TYPE))
 676                && (best_type = find_common_type (left_type, right_type)))
 677         operation_type = best_type;
 678
 679       /* Otherwise use the LHS type.  */
 680       else if (!operation_type)
 681         operation_type = left_type;
 682
 683       /* Ensure everything on the LHS is valid.  If we have a field reference,
 684          strip anything that get_inner_reference can handle.  Then remove any
 685          conversions between types having the same code and mode.  And mark
 686          VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE.  When done, we must have
 687          either an INDIRECT_REF, a NULL_EXPR or a DECL node.  */
 688       result = left_operand;
 689       while (true)
 690         {
 691           tree restype = TREE_TYPE (result);
 692
 693           if (TREE_CODE (result) == COMPONENT_REF
 694               || TREE_CODE (result) == ARRAY_REF
 695               || TREE_CODE (result) == ARRAY_RANGE_REF)
 696             while (handled_component_p (result))
 697               result = TREE_OPERAND (result, 0);
 698           else if (TREE_CODE (result) == REALPART_EXPR
 699                    || TREE_CODE (result) == IMAGPART_EXPR
 700                    || (CONVERT_EXPR_P (result)
 701                        && (((TREE_CODE (restype)
 702                              == TREE_CODE (TREE_TYPE
 703                                            (TREE_OPERAND (result, 0))))
 704                              && (TYPE_MODE (TREE_TYPE
 705                                             (TREE_OPERAND (result, 0)))
 706                                  == TYPE_MODE (restype)))
 707                            || TYPE_ALIGN_OK (restype))))
 708             result = TREE_OPERAND (result, 0);
 709           else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
 710             {
 711               TREE_ADDRESSABLE (result) = 1;
 712               result = TREE_OPERAND (result, 0);
 713             }
 714           else
 715             break;
 716         }
 717
 718       gcc_assert (TREE_CODE (result) == INDIRECT_REF
 719                   || TREE_CODE (result) == NULL_EXPR
 720                   || DECL_P (result));
 721
 722       /* Convert the right operand to the operation type unless it is
 723          either already of the correct type or if the type involves a
 724          placeholder, since the RHS may not have the same record type.  */
 725       if (operation_type != right_type
 726           && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type)))
 727         {
 728           right_operand = convert (operation_type, right_operand);
 729           right_type = operation_type;
 730         }
 731
 732       /* If the left operand is not of the same type as the operation
 733          type, wrap it up in a VIEW_CONVERT_EXPR.  */
 734       if (left_type != operation_type)
 735         left_operand = unchecked_convert (operation_type, left_operand, false);
 736
 737       has_side_effects = true;
 738       modulus = NULL_TREE;
 739       break;
 740
 741     case ARRAY_REF:
 742       if (!operation_type)
 743         operation_type = TREE_TYPE (left_type);
 744
 745       /* ... fall through ... */
 746
 747     case ARRAY_RANGE_REF:
 748       /* First look through conversion between type variants.  Note that
 749          this changes neither the operation type nor the type domain.  */
 750       if (TREE_CODE (left_operand) == VIEW_CONVERT_EXPR
 751           && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (left_operand, 0)))
 752              == TYPE_MAIN_VARIANT (left_type))
 753         {
 754           left_operand = TREE_OPERAND (left_operand, 0);
 755           left_type = TREE_TYPE (left_operand);
 756         }
 757
 758       /* For a range, make sure the element type is consistent.  */
 759       if (op_code == ARRAY_RANGE_REF
 760           && TREE_TYPE (operation_type) != TREE_TYPE (left_type))
 761         operation_type = build_array_type (TREE_TYPE (left_type),
 762                                            TYPE_DOMAIN (operation_type));
 763
 764       /* Then convert the right operand to its base type.  This will prevent
 765          unneeded sign conversions when sizetype is wider than integer.  */
 766       right_operand = convert (right_base_type, right_operand);
 767       right_operand = convert (sizetype, right_operand);
 768
 769       if (!TREE_CONSTANT (right_operand)
 770           || !TREE_CONSTANT (TYPE_MIN_VALUE (right_type)))
 771         gnat_mark_addressable (left_operand);
 772
 773       modulus = NULL_TREE;
 774       break;
 775
 776     case GE_EXPR:
 777     case LE_EXPR:
 778     case GT_EXPR:
 779     case LT_EXPR:
 780       gcc_assert (!POINTER_TYPE_P (left_type));
 781
 782       /* ... fall through ... */
 783
 784     case EQ_EXPR:
 785     case NE_EXPR:
 786       /* If either operand is a NULL_EXPR, just return a new one.  */
 787       if (TREE_CODE (left_operand) == NULL_EXPR)
 788         return build2 (op_code, result_type,
 789                        build1 (NULL_EXPR, integer_type_node,
 790                                TREE_OPERAND (left_operand, 0)),
 791                        integer_zero_node);
 792
 793       else if (TREE_CODE (right_operand) == NULL_EXPR)
 794         return build2 (op_code, result_type,
 795                        build1 (NULL_EXPR, integer_type_node,
 796                                TREE_OPERAND (right_operand, 0)),
 797                        integer_zero_node);
 798
 799       /* If either object is a justified modular types, get the
 800          fields from within.  */
 801       if (TREE_CODE (left_type) == RECORD_TYPE
 802           && TYPE_JUSTIFIED_MODULAR_P (left_type))
 803         {
 804           left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)),
 805                                   left_operand);
 806           left_type = TREE_TYPE (left_operand);
 807           left_base_type = get_base_type (left_type);
 808         }
 809
 810       if (TREE_CODE (right_type) == RECORD_TYPE
 811           && TYPE_JUSTIFIED_MODULAR_P (right_type))
 812         {
 813           right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)),
 814                                   right_operand);
 815           right_type = TREE_TYPE (right_operand);
 816           right_base_type = get_base_type (right_type);
 817         }
 818
 819       /* If both objects are arrays, compare them specially.  */
 820       if ((TREE_CODE (left_type) == ARRAY_TYPE
 821            || (TREE_CODE (left_type) == INTEGER_TYPE
 822                && TYPE_HAS_ACTUAL_BOUNDS_P (left_type)))
 823           && (TREE_CODE (right_type) == ARRAY_TYPE
 824               || (TREE_CODE (right_type) == INTEGER_TYPE
 825                   && TYPE_HAS_ACTUAL_BOUNDS_P (right_type))))
 826         {
 827           result = compare_arrays (result_type, left_operand, right_operand);
 828
 829           if (op_code == NE_EXPR)
 830             result = invert_truthvalue (result);
 831           else
 832             gcc_assert (op_code == EQ_EXPR);
 833
 834           return result;
 835         }
 836
 837       /* Otherwise, the base types must be the same unless the objects are
 838          fat pointers or records.  If we have records, use the best type and
 839          convert both operands to that type.  */
 840       if (left_base_type != right_base_type)
 841         {
 842           if (TYPE_IS_FAT_POINTER_P (left_base_type)
 843               && TYPE_IS_FAT_POINTER_P (right_base_type)
 844               && TYPE_MAIN_VARIANT (left_base_type)
 845                  == TYPE_MAIN_VARIANT (right_base_type))
 846             best_type = left_base_type;
 847           else if (TREE_CODE (left_base_type) == RECORD_TYPE
 848                    && TREE_CODE (right_base_type) == RECORD_TYPE)
 849             {
 850               /* The only way these are permitted to be the same is if both
 851                  types have the same name.  In that case, one of them must
 852                  not be self-referential.  Use that one as the best type.
 853                  Even better is if one is of fixed size.  */
 854               gcc_assert (TYPE_NAME (left_base_type)
 855                           && (TYPE_NAME (left_base_type)
 856                               == TYPE_NAME (right_base_type)));
 857
 858               if (TREE_CONSTANT (TYPE_SIZE (left_base_type)))
 859                 best_type = left_base_type;
 860               else if (TREE_CONSTANT (TYPE_SIZE (right_base_type)))
 861                 best_type = right_base_type;
 862               else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type)))
 863                 best_type = left_base_type;
 864               else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type)))
 865                 best_type = right_base_type;
 866               else
 867                 gcc_unreachable ();
 868             }
 869           else
 870             gcc_unreachable ();
 871
 872           left_operand = convert (best_type, left_operand);
 873           right_operand = convert (best_type, right_operand);
 874         }
 875
 876       /* If we are comparing a fat pointer against zero, we need to
 877          just compare the data pointer.  */
 878       else if (TYPE_IS_FAT_POINTER_P (left_base_type)
 879                && TREE_CODE (right_operand) == CONSTRUCTOR
 880                && integer_zerop (VEC_index (constructor_elt,
 881                                             CONSTRUCTOR_ELTS (right_operand),
 882                                             0)
 883                                  ->value))
 884         {
 885           right_operand = build_component_ref (left_operand, NULL_TREE,
 886                                                TYPE_FIELDS (left_base_type),
 887                                                false);
 888           left_operand = convert (TREE_TYPE (right_operand),
 889                                   integer_zero_node);
 890         }
 891       else
 892         {
 893           left_operand = convert (left_base_type, left_operand);
 894           right_operand = convert (right_base_type, right_operand);
 895         }
 896
 897       modulus = NULL_TREE;
 898       break;
 899
 900     case PREINCREMENT_EXPR:
 901     case PREDECREMENT_EXPR:
 902     case POSTINCREMENT_EXPR:
 903     case POSTDECREMENT_EXPR:
 904       /* These operations are not used anymore.  */
 905       gcc_unreachable ();
 906
 907     case LSHIFT_EXPR:
 908     case RSHIFT_EXPR:
 909     case LROTATE_EXPR:
 910     case RROTATE_EXPR:
 911        /* The RHS of a shift can be any type.  Also, ignore any modulus
 912          (we used to abort, but this is needed for unchecked conversion
 913          to modular types).  Otherwise, processing is the same as normal.  */
 914       gcc_assert (operation_type == left_base_type);
 915       modulus = NULL_TREE;
 916       left_operand = convert (operation_type, left_operand);
 917       break;
 918
 919     case BIT_AND_EXPR:
 920     case BIT_IOR_EXPR:
 921     case BIT_XOR_EXPR:
 922       /* For binary modulus, if the inputs are in range, so are the
 923          outputs.  */
 924       if (modulus && integer_pow2p (modulus))
 925         modulus = NULL_TREE;
 926       goto common;
 927
 928     case COMPLEX_EXPR:
 929       gcc_assert (TREE_TYPE (result_type) == left_base_type
 930                   && TREE_TYPE (result_type) == right_base_type);
 931       left_operand = convert (left_base_type, left_operand);
 932       right_operand = convert (right_base_type, right_operand);
 933       break;
 934
 935     case TRUNC_DIV_EXPR:   case TRUNC_MOD_EXPR:
 936     case CEIL_DIV_EXPR:    case CEIL_MOD_EXPR:
 937     case FLOOR_DIV_EXPR:   case FLOOR_MOD_EXPR:
 938     case ROUND_DIV_EXPR:   case ROUND_MOD_EXPR:
 939       /* These always produce results lower than either operand.  */
 940       modulus = NULL_TREE;
 941       goto common;
 942
 943     case POINTER_PLUS_EXPR:
 944       gcc_assert (operation_type == left_base_type
 945                   && sizetype == right_base_type);
 946       left_operand = convert (operation_type, left_operand);
 947       right_operand = convert (sizetype, right_operand);
 948       break;
 949
 950     case PLUS_NOMOD_EXPR:
 951     case MINUS_NOMOD_EXPR:
 952       if (op_code == PLUS_NOMOD_EXPR)
 953         op_code = PLUS_EXPR;
 954       else
 955         op_code = MINUS_EXPR;
 956       modulus = NULL_TREE;
 957
 958       /* ... fall through ... */
 959
 960     case PLUS_EXPR:
 961     case MINUS_EXPR:
 962       /* Avoid doing arithmetics in ENUMERAL_TYPE or BOOLEAN_TYPE like the
 963          other compilers.  Contrary to C, Ada doesn't allow arithmetics in
 964          these types but can generate addition/subtraction for Succ/Pred.  */
 965       if (operation_type
 966           && (TREE_CODE (operation_type) == ENUMERAL_TYPE
 967               || TREE_CODE (operation_type) == BOOLEAN_TYPE))
 968         operation_type = left_base_type = right_base_type
 969           = gnat_type_for_mode (TYPE_MODE (operation_type),
 970                                 TYPE_UNSIGNED (operation_type));
 971
 972       /* ... fall through ... */
 973
 974     default:
 975     common:
 976       /* The result type should be the same as the base types of the
 977          both operands (and they should be the same).  Convert
 978          everything to the result type.  */
 979
 980       gcc_assert (operation_type == left_base_type
 981                   && left_base_type == right_base_type);
 982       left_operand = convert (operation_type, left_operand);
 983       right_operand = convert (operation_type, right_operand);
 984     }
 985
 986   if (modulus && !integer_pow2p (modulus))
 987     {
 988       result = nonbinary_modular_operation (op_code, operation_type,
 989                                             left_operand, right_operand);
 990       modulus = NULL_TREE;
 991     }
 992   /* If either operand is a NULL_EXPR, just return a new one.  */
 993   else if (TREE_CODE (left_operand) == NULL_EXPR)
 994     return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0));
 995   else if (TREE_CODE (right_operand) == NULL_EXPR)
 996     return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
 997   else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
 998     result = fold (build4 (op_code, operation_type, left_operand,
 999                            right_operand, NULL_TREE, NULL_TREE));
1000   else
1001     result
1002       = fold_build2 (op_code, operation_type, left_operand, right_operand);
1003
1004   TREE_SIDE_EFFECTS (result) |= has_side_effects;
1005   TREE_CONSTANT (result)
1006     |= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
1007         && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF);
1008
1009   if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
1010       && TYPE_VOLATILE (operation_type))
1011     TREE_THIS_VOLATILE (result) = 1;
1012
1013   /* If we are working with modular types, perform the MOD operation
1014      if something above hasn't eliminated the need for it.  */
1015   if (modulus)
1016     result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result,
1017                           convert (operation_type, modulus));
1018
1019   if (result_type && result_type != operation_type)
1020     result = convert (result_type, result);
1021
1022   return result;
1023 }
1024 \f
1025 /* Similar, but for unary operations.  */
1026
1027 tree
1028 build_unary_op (enum tree_code op_code, tree result_type, tree operand)
1029 {
1030   tree type = TREE_TYPE (operand);
1031   tree base_type = get_base_type (type);
1032   tree operation_type = result_type;
1033   tree result;
1034   bool side_effects = false;
1035
1036   if (operation_type
1037       && TREE_CODE (operation_type) == RECORD_TYPE
1038       && TYPE_JUSTIFIED_MODULAR_P (operation_type))
1039     operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
1040
1041   if (operation_type
1042       && !AGGREGATE_TYPE_P (operation_type)
1043       && TYPE_EXTRA_SUBTYPE_P (operation_type))
1044     operation_type = get_base_type (operation_type);
1045
1046   switch (op_code)
1047     {
1048     case REALPART_EXPR:
1049     case IMAGPART_EXPR:
1050       if (!operation_type)
1051         result_type = operation_type = TREE_TYPE (type);
1052       else
1053         gcc_assert (result_type == TREE_TYPE (type));
1054
1055       result = fold_build1 (op_code, operation_type, operand);
1056       break;
1057
1058     case TRUTH_NOT_EXPR:
1059       gcc_assert (result_type == base_type);
1060       result = invert_truthvalue (operand);
1061       break;
1062
1063     case ATTR_ADDR_EXPR:
1064     case ADDR_EXPR:
1065       switch (TREE_CODE (operand))
1066         {
1067         case INDIRECT_REF:
1068         case UNCONSTRAINED_ARRAY_REF:
1069           result = TREE_OPERAND (operand, 0);
1070
1071           /* Make sure the type here is a pointer, not a reference.
1072              GCC wants pointer types for function addresses.  */
1073           if (!result_type)
1074             result_type = build_pointer_type (type);
1075
1076           /* If the underlying object can alias everything, propagate the
1077              property since we are effectively retrieving the object.  */
1078           if (POINTER_TYPE_P (TREE_TYPE (result))
1079               && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result)))
1080             {
1081               if (TREE_CODE (result_type) == POINTER_TYPE
1082                   && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1083                 result_type
1084                   = build_pointer_type_for_mode (TREE_TYPE (result_type),
1085                                                  TYPE_MODE (result_type),
1086                                                  true);
1087               else if (TREE_CODE (result_type) == REFERENCE_TYPE
1088                        && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1089                 result_type
1090                   = build_reference_type_for_mode (TREE_TYPE (result_type),
1091                                                    TYPE_MODE (result_type),
1092                                                    true);
1093             }
1094           break;
1095
1096         case NULL_EXPR:
1097           result = operand;
1098           TREE_TYPE (result) = type = build_pointer_type (type);
1099           break;
1100
1101         case ARRAY_REF:
1102         case ARRAY_RANGE_REF:
1103         case COMPONENT_REF:
1104         case BIT_FIELD_REF:
1105             /* If this is for 'Address, find the address of the prefix and
1106                add the offset to the field.  Otherwise, do this the normal
1107                way.  */
1108           if (op_code == ATTR_ADDR_EXPR)
1109             {
1110               HOST_WIDE_INT bitsize;
1111               HOST_WIDE_INT bitpos;
1112               tree offset, inner;
1113               enum machine_mode mode;
1114               int unsignedp, volatilep;
1115
1116               inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
1117                                            &mode, &unsignedp, &volatilep,
1118                                            false);
1119
1120               /* If INNER is a padding type whose field has a self-referential
1121                  size, convert to that inner type.  We know the offset is zero
1122                  and we need to have that type visible.  */
1123               if (TYPE_IS_PADDING_P (TREE_TYPE (inner))
1124                   && CONTAINS_PLACEHOLDER_P
1125                      (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
1126                                             (TREE_TYPE (inner))))))
1127                 inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
1128                                  inner);
1129
1130               /* Compute the offset as a byte offset from INNER.  */
1131               if (!offset)
1132                 offset = size_zero_node;
1133
1134               if (bitpos % BITS_PER_UNIT != 0)
1135                 post_error
1136                   ("taking address of object not aligned on storage unit?",
1137                    error_gnat_node);
1138
1139               offset = size_binop (PLUS_EXPR, offset,
1140                                    size_int (bitpos / BITS_PER_UNIT));
1141
1142               /* Take the address of INNER, convert the offset to void *, and
1143                  add then.  It will later be converted to the desired result
1144                  type, if any.  */
1145               inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner);
1146               inner = convert (ptr_void_type_node, inner);
1147               result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1148                                         inner, offset);
1149               result = convert (build_pointer_type (TREE_TYPE (operand)),
1150                                 result);
1151               break;
1152             }
1153           goto common;
1154
1155         case CONSTRUCTOR:
1156           /* If this is just a constructor for a padded record, we can
1157              just take the address of the single field and convert it to
1158              a pointer to our type.  */
1159           if (TYPE_IS_PADDING_P (type))
1160             {
1161               result = VEC_index (constructor_elt,
1162                                   CONSTRUCTOR_ELTS (operand),
1163                                   0)->value;
1164               result = convert (build_pointer_type (TREE_TYPE (operand)),
1165                                 build_unary_op (ADDR_EXPR, NULL_TREE, result));
1166               break;
1167             }
1168
1169           goto common;
1170
1171         case NOP_EXPR:
1172           if (AGGREGATE_TYPE_P (type)
1173               && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0))))
1174             return build_unary_op (ADDR_EXPR, result_type,
1175                                    TREE_OPERAND (operand, 0));
1176
1177           /* ... fallthru ... */
1178
1179         case VIEW_CONVERT_EXPR:
1180           /* If this just a variant conversion or if the conversion doesn't
1181              change the mode, get the result type from this type and go down.
1182              This is needed for conversions of CONST_DECLs, to eventually get
1183              to the address of their CORRESPONDING_VARs.  */
1184           if ((TYPE_MAIN_VARIANT (type)
1185                == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0))))
1186               || (TYPE_MODE (type) != BLKmode
1187                   && (TYPE_MODE (type)
1188                       == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))))
1189             return build_unary_op (ADDR_EXPR,
1190                                    (result_type ? result_type
1191                                     : build_pointer_type (type)),
1192                                    TREE_OPERAND (operand, 0));
1193           goto common;
1194
1195         case CONST_DECL:
1196           operand = DECL_CONST_CORRESPONDING_VAR (operand);
1197
1198           /* ... fall through ... */
1199
1200         default:
1201         common:
1202
1203           /* If we are taking the address of a padded record whose field is
1204              contains a template, take the address of the template.  */
1205           if (TYPE_IS_PADDING_P (type)
1206               && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
1207               && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
1208             {
1209               type = TREE_TYPE (TYPE_FIELDS (type));
1210               operand = convert (type, operand);
1211             }
1212
1213           if (type != error_mark_node)
1214             operation_type = build_pointer_type (type);
1215
1216           gnat_mark_addressable (operand);
1217           result = fold_build1 (ADDR_EXPR, operation_type, operand);
1218         }
1219
1220       TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
1221       break;
1222
1223     case INDIRECT_REF:
1224       /* If we want to refer to an entire unconstrained array,
1225          make up an expression to do so.  This will never survive to
1226          the backend.  If TYPE is a thin pointer, first convert the
1227          operand to a fat pointer.  */
1228       if (TYPE_IS_THIN_POINTER_P (type)
1229           && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
1230         {
1231           operand
1232             = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))),
1233                        operand);
1234           type = TREE_TYPE (operand);
1235         }
1236
1237       if (TYPE_IS_FAT_POINTER_P (type))
1238         {
1239           result = build1 (UNCONSTRAINED_ARRAY_REF,
1240                            TYPE_UNCONSTRAINED_ARRAY (type), operand);
1241           TREE_READONLY (result) = TREE_STATIC (result)
1242             = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type));
1243         }
1244       else if (TREE_CODE (operand) == ADDR_EXPR)
1245         result = TREE_OPERAND (operand, 0);
1246
1247       else
1248         {
1249           result = fold_build1 (op_code, TREE_TYPE (type), operand);
1250           TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type));
1251         }
1252
1253       side_effects
1254         = (!TYPE_IS_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
1255       break;
1256
1257     case NEGATE_EXPR:
1258     case BIT_NOT_EXPR:
1259       {
1260         tree modulus = ((operation_type
1261                          && TREE_CODE (operation_type) == INTEGER_TYPE
1262                          && TYPE_MODULAR_P (operation_type))
1263                         ? TYPE_MODULUS (operation_type) : NULL_TREE);
1264         int mod_pow2 = modulus && integer_pow2p (modulus);
1265
1266         /* If this is a modular type, there are various possibilities
1267            depending on the operation and whether the modulus is a
1268            power of two or not.  */
1269
1270         if (modulus)
1271           {
1272             gcc_assert (operation_type == base_type);
1273             operand = convert (operation_type, operand);
1274
1275             /* The fastest in the negate case for binary modulus is
1276                the straightforward code; the TRUNC_MOD_EXPR below
1277                is an AND operation.  */
1278             if (op_code == NEGATE_EXPR && mod_pow2)
1279               result = fold_build2 (TRUNC_MOD_EXPR, operation_type,
1280                                     fold_build1 (NEGATE_EXPR, operation_type,
1281                                                  operand),
1282                                     modulus);
1283
1284             /* For nonbinary negate case, return zero for zero operand,
1285                else return the modulus minus the operand.  If the modulus
1286                is a power of two minus one, we can do the subtraction
1287                as an XOR since it is equivalent and faster on most machines. */
1288             else if (op_code == NEGATE_EXPR && !mod_pow2)
1289               {
1290                 if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type,
1291                                                 modulus,
1292                                                 convert (operation_type,
1293                                                          integer_one_node))))
1294                   result = fold_build2 (BIT_XOR_EXPR, operation_type,
1295                                         operand, modulus);
1296                 else
1297                   result = fold_build2 (MINUS_EXPR, operation_type,
1298                                         modulus, operand);
1299
1300                 result = fold_build3 (COND_EXPR, operation_type,
1301                                       fold_build2 (NE_EXPR,
1302                                                    integer_type_node,
1303                                                    operand,
1304                                                    convert
1305                                                      (operation_type,
1306                                                       integer_zero_node)),
1307                                       result, operand);
1308               }
1309             else
1310               {
1311                 /* For the NOT cases, we need a constant equal to
1312                    the modulus minus one.  For a binary modulus, we
1313                    XOR against the constant and subtract the operand from
1314                    that constant for nonbinary modulus.  */
1315
1316                 tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus,
1317                                          convert (operation_type,
1318                                                   integer_one_node));
1319
1320                 if (mod_pow2)
1321                   result = fold_build2 (BIT_XOR_EXPR, operation_type,
1322                                         operand, cnst);
1323                 else
1324                   result = fold_build2 (MINUS_EXPR, operation_type,
1325                                         cnst, operand);
1326               }
1327
1328             break;
1329           }
1330       }
1331
1332       /* ... fall through ... */
1333
1334     default:
1335       gcc_assert (operation_type == base_type);
1336       result = fold_build1 (op_code, operation_type,
1337                             convert (operation_type, operand));
1338     }
1339
1340   if (side_effects)
1341     {
1342       TREE_SIDE_EFFECTS (result) = 1;
1343       if (TREE_CODE (result) == INDIRECT_REF)
1344         TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
1345     }
1346
1347   if (result_type && TREE_TYPE (result) != result_type)
1348     result = convert (result_type, result);
1349
1350   return result;
1351 }
1352 \f
1353 /* Similar, but for COND_EXPR.  */
1354
1355 tree
1356 build_cond_expr (tree result_type, tree condition_operand,
1357                  tree true_operand, tree false_operand)
1358 {
1359   bool addr_p = false;
1360   tree result;
1361
1362   /* The front-end verified that result, true and false operands have
1363      same base type.  Convert everything to the result type.  */
1364   true_operand = convert (result_type, true_operand);
1365   false_operand = convert (result_type, false_operand);
1366
1367   /* If the result type is unconstrained, take the address of the operands
1368      and then dereference our result.  */
1369   if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
1370       || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
1371     {
1372       result_type = build_pointer_type (result_type);
1373       true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand);
1374       false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
1375       addr_p = true;
1376     }
1377
1378   result = fold_build3 (COND_EXPR, result_type, condition_operand,
1379                         true_operand, false_operand);
1380
1381   /* If we have a common SAVE_EXPR (possibly surrounded by arithmetics)
1382      in both arms, make sure it gets evaluated by moving it ahead of the
1383      conditional expression.  This is necessary because it is evaluated
1384      in only one place at run time and would otherwise be uninitialized
1385      in one of the arms.  */
1386   true_operand = skip_simple_arithmetic (true_operand);
1387   false_operand = skip_simple_arithmetic (false_operand);
1388
1389   if (true_operand == false_operand && TREE_CODE (true_operand) == SAVE_EXPR)
1390     result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
1391
1392   if (addr_p)
1393     result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
1394
1395   return result;
1396 }
1397
1398 /* Similar, but for RETURN_EXPR.  If RESULT_DECL is non-zero, build
1399    a RETURN_EXPR around the assignment of RET_VAL to RESULT_DECL.
1400    If RESULT_DECL is zero, build a bare RETURN_EXPR.  */
1401
1402 tree
1403 build_return_expr (tree result_decl, tree ret_val)
1404 {
1405   tree result_expr;
1406
1407   if (result_decl)
1408     {
1409       /* The gimplifier explicitly enforces the following invariant:
1410
1411            RETURN_EXPR
1412                |
1413            MODIFY_EXPR
1414            /        \
1415           /          \
1416       RESULT_DECL    ...
1417
1418       As a consequence, type-homogeneity dictates that we use the type
1419       of the RESULT_DECL as the operation type.  */
1420
1421       tree operation_type = TREE_TYPE (result_decl);
1422
1423       /* Convert the right operand to the operation type.  Note that
1424          it's the same transformation as in the MODIFY_EXPR case of
1425          build_binary_op with the additional guarantee that the type
1426          cannot involve a placeholder, since otherwise the function
1427          would use the "target pointer" return mechanism.  */
1428
1429       if (operation_type != TREE_TYPE (ret_val))
1430         ret_val = convert (operation_type, ret_val);
1431
1432       result_expr
1433         = build2 (MODIFY_EXPR, operation_type, result_decl, ret_val);
1434     }
1435   else
1436     result_expr = NULL_TREE;
1437
1438   return build1 (RETURN_EXPR, void_type_node, result_expr);
1439 }
1440 \f
1441 /* Build a CALL_EXPR to call FUNDECL with one argument, ARG.  Return
1442    the CALL_EXPR.  */
1443
1444 tree
1445 build_call_1_expr (tree fundecl, tree arg)
1446 {
1447   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1448                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1449                                1, arg);
1450   TREE_SIDE_EFFECTS (call) = 1;
1451   return call;
1452 }
1453
1454 /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2.  Return
1455    the CALL_EXPR.  */
1456
1457 tree
1458 build_call_2_expr (tree fundecl, tree arg1, tree arg2)
1459 {
1460   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1461                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1462                                2, arg1, arg2);
1463   TREE_SIDE_EFFECTS (call) = 1;
1464   return call;
1465 }
1466
1467 /* Likewise to call FUNDECL with no arguments.  */
1468
1469 tree
1470 build_call_0_expr (tree fundecl)
1471 {
1472   /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS.  This makes
1473      it possible to propagate DECL_IS_PURE on parameterless functions.  */
1474   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1475                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1476                                0);
1477   return call;
1478 }
1479 \f
1480 /* Call a function that raises an exception and pass the line number and file
1481    name, if requested.  MSG says which exception function to call.
1482
1483    GNAT_NODE is the gnat node conveying the source location for which the
1484    error should be signaled, or Empty in which case the error is signaled on
1485    the current ref_file_name/input_line.
1486
1487    KIND says which kind of exception this is for
1488    (N_Raise_{Constraint,Storage,Program}_Error).  */
1489
1490 tree
1491 build_call_raise (int msg, Node_Id gnat_node, char kind)
1492 {
1493   tree fndecl = gnat_raise_decls[msg];
1494   tree label = get_exception_label (kind);
1495   tree filename;
1496   int line_number;
1497   const char *str;
1498   int len;
1499
1500   /* If this is to be done as a goto, handle that case.  */
1501   if (label)
1502     {
1503       Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
1504       tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
1505
1506       /* If Local_Raise is present, generate
1507          Local_Raise (exception'Identity);  */
1508       if (Present (local_raise))
1509         {
1510           tree gnu_local_raise
1511             = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
1512           tree gnu_exception_entity
1513             = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
1514           tree gnu_call
1515             = build_call_1_expr (gnu_local_raise,
1516                                  build_unary_op (ADDR_EXPR, NULL_TREE,
1517                                                  gnu_exception_entity));
1518
1519           gnu_result = build2 (COMPOUND_EXPR, void_type_node,
1520                                gnu_call, gnu_result);}
1521
1522       return gnu_result;
1523     }
1524
1525   str
1526     = (Debug_Flag_NN || Exception_Locations_Suppressed)
1527       ? ""
1528       : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1529         ? IDENTIFIER_POINTER
1530           (get_identifier (Get_Name_String
1531                            (Debug_Source_Name
1532                             (Get_Source_File_Index (Sloc (gnat_node))))))
1533         : ref_filename;
1534
1535   len = strlen (str);
1536   filename = build_string (len, str);
1537   line_number
1538     = (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1539       ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
1540
1541   TREE_TYPE (filename)
1542     = build_array_type (char_type_node, build_index_type (size_int (len)));
1543
1544   return
1545     build_call_2_expr (fndecl,
1546                        build1 (ADDR_EXPR, build_pointer_type (char_type_node),
1547                                filename),
1548                        build_int_cst (NULL_TREE, line_number));
1549 }
1550 \f
1551 /* qsort comparer for the bit positions of two constructor elements
1552    for record components.  */
1553
1554 static int
1555 compare_elmt_bitpos (const PTR rt1, const PTR rt2)
1556 {
1557   const_tree const elmt1 = * (const_tree const *) rt1;
1558   const_tree const elmt2 = * (const_tree const *) rt2;
1559   const_tree const field1 = TREE_PURPOSE (elmt1);
1560   const_tree const field2 = TREE_PURPOSE (elmt2);
1561   const int ret
1562     = tree_int_cst_compare (bit_position (field1), bit_position (field2));
1563
1564   return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
1565 }
1566
1567 /* Return a CONSTRUCTOR of TYPE whose list is LIST.  */
1568
1569 tree
1570 gnat_build_constructor (tree type, tree list)
1571 {
1572   bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
1573   bool side_effects = false;
1574   tree elmt, result;
1575   int n_elmts;
1576
1577   /* Scan the elements to see if they are all constant or if any has side
1578      effects, to let us set global flags on the resulting constructor.  Count
1579      the elements along the way for possible sorting purposes below.  */
1580   for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++)
1581     {
1582       tree obj = TREE_PURPOSE (elmt);
1583       tree val = TREE_VALUE (elmt);
1584
1585       /* The predicate must be in keeping with output_constructor.  */
1586       if (!TREE_CONSTANT (val)
1587           || (TREE_CODE (type) == RECORD_TYPE
1588               && CONSTRUCTOR_BITFIELD_P (obj)
1589               && !initializer_constant_valid_for_bitfield_p (val))
1590           || !initializer_constant_valid_p (val, TREE_TYPE (val)))
1591         allconstant = false;
1592
1593       if (TREE_SIDE_EFFECTS (val))
1594         side_effects = true;
1595
1596       /* Propagate an NULL_EXPR from the size of the type.  We won't ever
1597          be executing the code we generate here in that case, but handle it
1598          specially to avoid the compiler blowing up.  */
1599       if (TREE_CODE (type) == RECORD_TYPE
1600           && (result = contains_null_expr (DECL_SIZE (obj))) != NULL_TREE)
1601         return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0));
1602     }
1603
1604   /* For record types with constant components only, sort field list
1605      by increasing bit position.  This is necessary to ensure the
1606      constructor can be output as static data.  */
1607   if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
1608     {
1609       /* Fill an array with an element tree per index, and ask qsort to order
1610          them according to what a bitpos comparison function says.  */
1611       tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
1612       int i;
1613
1614       for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++)
1615         gnu_arr[i] = elmt;
1616
1617       qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
1618
1619       /* Then reconstruct the list from the sorted array contents.  */
1620       list = NULL_TREE;
1621       for (i = n_elmts - 1; i >= 0; i--)
1622         {
1623           TREE_CHAIN (gnu_arr[i]) = list;
1624           list = gnu_arr[i];
1625         }
1626     }
1627
1628   result = build_constructor_from_list (type, list);
1629   TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant;
1630   TREE_SIDE_EFFECTS (result) = side_effects;
1631   TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
1632   return result;
1633 }
1634 \f
1635 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
1636    an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
1637    for the field.  Don't fold the result if NO_FOLD_P is true.
1638
1639    We also handle the fact that we might have been passed a pointer to the
1640    actual record and know how to look for fields in variant parts.  */
1641
1642 static tree
1643 build_simple_component_ref (tree record_variable, tree component,
1644                             tree field, bool no_fold_p)
1645 {
1646   tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
1647   tree ref, inner_variable;
1648
1649   gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE
1650                || TREE_CODE (record_type) == UNION_TYPE
1651                || TREE_CODE (record_type) == QUAL_UNION_TYPE)
1652               && TYPE_SIZE (record_type)
1653               && (component != 0) != (field != 0));
1654
1655   /* If no field was specified, look for a field with the specified name
1656      in the current record only.  */
1657   if (!field)
1658     for (field = TYPE_FIELDS (record_type); field;
1659          field = TREE_CHAIN (field))
1660       if (DECL_NAME (field) == component)
1661         break;
1662
1663   if (!field)
1664     return NULL_TREE;
1665
1666   /* If this field is not in the specified record, see if we can find
1667      something in the record whose original field is the same as this one. */
1668   if (DECL_CONTEXT (field) != record_type)
1669     /* Check if there is a field with name COMPONENT in the record.  */
1670     {
1671       tree new_field;
1672
1673       /* First loop thru normal components.  */
1674
1675       for (new_field = TYPE_FIELDS (record_type); new_field;
1676            new_field = TREE_CHAIN (new_field))
1677         if (field == new_field
1678             || DECL_ORIGINAL_FIELD (new_field) == field
1679             || new_field == DECL_ORIGINAL_FIELD (field)
1680             || (DECL_ORIGINAL_FIELD (field)
1681                 && (DECL_ORIGINAL_FIELD (field)
1682                     == DECL_ORIGINAL_FIELD (new_field))))
1683           break;
1684
1685       /* Next, loop thru DECL_INTERNAL_P components if we haven't found
1686          the component in the first search. Doing this search in 2 steps
1687          is required to avoiding hidden homonymous fields in the
1688          _Parent field.  */
1689
1690       if (!new_field)
1691         for (new_field = TYPE_FIELDS (record_type); new_field;
1692              new_field = TREE_CHAIN (new_field))
1693           if (DECL_INTERNAL_P (new_field))
1694             {
1695               tree field_ref
1696                 = build_simple_component_ref (record_variable,
1697                                               NULL_TREE, new_field, no_fold_p);
1698               ref = build_simple_component_ref (field_ref, NULL_TREE, field,
1699                                                 no_fold_p);
1700
1701               if (ref)
1702                 return ref;
1703             }
1704
1705       field = new_field;
1706     }
1707
1708   if (!field)
1709     return NULL_TREE;
1710
1711   /* If the field's offset has overflowed, do not attempt to access it
1712      as doing so may trigger sanity checks deeper in the back-end.
1713      Note that we don't need to warn since this will be done on trying
1714      to declare the object.  */
1715   if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST
1716       && TREE_OVERFLOW (DECL_FIELD_OFFSET (field)))
1717     return NULL_TREE;
1718
1719   /* Look through conversion between type variants.  Note that this
1720      is transparent as far as the field is concerned.  */
1721   if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
1722       && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
1723          == record_type)
1724     inner_variable = TREE_OPERAND (record_variable, 0);
1725   else
1726     inner_variable = record_variable;
1727
1728   ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field,
1729                 NULL_TREE);
1730
1731   if (TREE_READONLY (record_variable) || TREE_READONLY (field))
1732     TREE_READONLY (ref) = 1;
1733   if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
1734       || TYPE_VOLATILE (record_type))
1735     TREE_THIS_VOLATILE (ref) = 1;
1736
1737   if (no_fold_p)
1738     return ref;
1739
1740   /* The generic folder may punt in this case because the inner array type
1741      can be self-referential, but folding is in fact not problematic.  */
1742   else if (TREE_CODE (record_variable) == CONSTRUCTOR
1743            && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable)))
1744     {
1745       VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable);
1746       unsigned HOST_WIDE_INT idx;
1747       tree index, value;
1748       FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
1749         if (index == field)
1750           return value;
1751       return ref;
1752     }
1753
1754   else
1755     return fold (ref);
1756 }
1757 \f
1758 /* Like build_simple_component_ref, except that we give an error if the
1759    reference could not be found.  */
1760
1761 tree
1762 build_component_ref (tree record_variable, tree component,
1763                      tree field, bool no_fold_p)
1764 {
1765   tree ref = build_simple_component_ref (record_variable, component, field,
1766                                          no_fold_p);
1767
1768   if (ref)
1769     return ref;
1770
1771   /* If FIELD was specified, assume this is an invalid user field so raise
1772      Constraint_Error.  Otherwise, we have no type to return so abort.  */
1773   gcc_assert (field);
1774   return build1 (NULL_EXPR, TREE_TYPE (field),
1775                  build_call_raise (CE_Discriminant_Check_Failed, Empty,
1776                                    N_Raise_Constraint_Error));
1777 }
1778 \f
1779 /* Helper for build_call_alloc_dealloc, with arguments to be interpreted
1780    identically.  Process the case where a GNAT_PROC to call is provided.  */
1781
1782 static inline tree
1783 build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
1784                                Entity_Id gnat_proc, Entity_Id gnat_pool)
1785 {
1786   tree gnu_proc = gnat_to_gnu (gnat_proc);
1787   tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
1788   tree gnu_call;
1789
1790   /* The storage pools are obviously always tagged types, but the
1791      secondary stack uses the same mechanism and is not tagged.  */
1792   if (Is_Tagged_Type (Etype (gnat_pool)))
1793     {
1794       /* The size is the third parameter; the alignment is the
1795          same type.  */
1796       Entity_Id gnat_size_type
1797         = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
1798       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1799
1800       tree gnu_pool = gnat_to_gnu (gnat_pool);
1801       tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
1802       tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
1803
1804       gnu_size = convert (gnu_size_type, gnu_size);
1805       gnu_align = convert (gnu_size_type, gnu_align);
1806
1807       /* The first arg is always the address of the storage pool; next
1808          comes the address of the object, for a deallocator, then the
1809          size and alignment.  */
1810       if (gnu_obj)
1811         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1812                                     gnu_proc_addr, 4, gnu_pool_addr,
1813                                     gnu_obj, gnu_size, gnu_align);
1814       else
1815         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1816                                     gnu_proc_addr, 3, gnu_pool_addr,
1817                                     gnu_size, gnu_align);
1818     }
1819
1820   /* Secondary stack case.  */
1821   else
1822     {
1823       /* The size is the second parameter.  */
1824       Entity_Id gnat_size_type
1825         = Etype (Next_Formal (First_Formal (gnat_proc)));
1826       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1827
1828       gnu_size = convert (gnu_size_type, gnu_size);
1829
1830       /* The first arg is the address of the object, for a deallocator,
1831          then the size.  */
1832       if (gnu_obj)
1833         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1834                                     gnu_proc_addr, 2, gnu_obj, gnu_size);
1835       else
1836         gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1837                                     gnu_proc_addr, 1, gnu_size);
1838     }
1839
1840   TREE_SIDE_EFFECTS (gnu_call) = 1;
1841   return gnu_call;
1842 }
1843
1844 /* Helper for build_call_alloc_dealloc, to build and return an allocator for
1845    DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default
1846    __gnat_malloc allocator.  Honor DATA_TYPE alignments greater than what the
1847    latter offers.  */
1848
1849 static inline tree
1850 maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
1851 {
1852   /* When the DATA_TYPE alignment is stricter than what malloc offers
1853      (super-aligned case), we allocate an "aligning" wrapper type and return
1854      the address of its single data field with the malloc's return value
1855      stored just in front.  */
1856
1857   unsigned int data_align = TYPE_ALIGN (data_type);
1858   unsigned int default_allocator_alignment
1859       = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1860
1861   tree aligning_type
1862     = ((data_align > default_allocator_alignment)
1863        ? make_aligning_type (data_type, data_align, data_size,
1864                              default_allocator_alignment,
1865                              POINTER_SIZE / BITS_PER_UNIT)
1866        : NULL_TREE);
1867
1868   tree size_to_malloc
1869     = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
1870
1871   tree malloc_ptr;
1872
1873   /* On VMS, if 64-bit memory is disabled or pointers are 64-bit and the
1874      allocator size is 32-bit or Convention C, allocate 32-bit memory.  */
1875   if (TARGET_ABI_OPEN_VMS
1876       && (!TARGET_MALLOC64
1877           || (POINTER_SIZE == 64
1878               && (UI_To_Int (Esize (Etype (gnat_node))) == 32
1879                   || Convention (Etype (gnat_node)) == Convention_C))))
1880     malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc);
1881   else
1882     malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc);
1883
1884   if (aligning_type)
1885     {
1886       /* Latch malloc's return value and get a pointer to the aligning field
1887          first.  */
1888       tree storage_ptr = save_expr (malloc_ptr);
1889
1890       tree aligning_record_addr
1891         = convert (build_pointer_type (aligning_type), storage_ptr);
1892
1893       tree aligning_record
1894         = build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr);
1895
1896       tree aligning_field
1897         = build_component_ref (aligning_record, NULL_TREE,
1898                                TYPE_FIELDS (aligning_type), 0);
1899
1900       tree aligning_field_addr
1901         = build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
1902
1903       /* Then arrange to store the allocator's return value ahead
1904          and return.  */
1905       tree storage_ptr_slot_addr
1906         = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1907                            convert (ptr_void_type_node, aligning_field_addr),
1908                            size_int (-(HOST_WIDE_INT) POINTER_SIZE
1909                                      / BITS_PER_UNIT));
1910
1911       tree storage_ptr_slot
1912         = build_unary_op (INDIRECT_REF, NULL_TREE,
1913                           convert (build_pointer_type (ptr_void_type_node),
1914                                    storage_ptr_slot_addr));
1915
1916       return
1917         build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr),
1918                 build_binary_op (MODIFY_EXPR, NULL_TREE,
1919                                  storage_ptr_slot, storage_ptr),
1920                 aligning_field_addr);
1921     }
1922   else
1923     return malloc_ptr;
1924 }
1925
1926 /* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object
1927    designated by DATA_PTR using the __gnat_free entry point.  */
1928
1929 static inline tree
1930 maybe_wrap_free (tree data_ptr, tree data_type)
1931 {
1932   /* In the regular alignment case, we pass the data pointer straight to free.
1933      In the superaligned case, we need to retrieve the initial allocator
1934      return value, stored in front of the data block at allocation time.  */
1935
1936   unsigned int data_align = TYPE_ALIGN (data_type);
1937   unsigned int default_allocator_alignment
1938       = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1939
1940   tree free_ptr;
1941
1942   if (data_align > default_allocator_alignment)
1943     {
1944       /* DATA_FRONT_PTR (void *)
1945          = (void *)DATA_PTR - (void *)sizeof (void *))  */
1946       tree data_front_ptr
1947         = build_binary_op
1948           (POINTER_PLUS_EXPR, ptr_void_type_node,
1949            convert (ptr_void_type_node, data_ptr),
1950            size_int (-(HOST_WIDE_INT) POINTER_SIZE / BITS_PER_UNIT));
1951
1952       /* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR  */
1953       free_ptr
1954         = build_unary_op
1955           (INDIRECT_REF, NULL_TREE,
1956            convert (build_pointer_type (ptr_void_type_node), data_front_ptr));
1957     }
1958   else
1959     free_ptr = data_ptr;
1960
1961   return build_call_1_expr (free_decl, free_ptr);
1962 }
1963
1964 /* Build a GCC tree to call an allocation or deallocation function.
1965    If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
1966    generate an allocator.
1967
1968    GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
1969    object type, used to determine the to-be-honored address alignment.
1970    GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
1971    pool to use.  If not present, malloc and free are used.  GNAT_NODE is used
1972    to provide an error location for restriction violation messages.  */
1973
1974 tree
1975 build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
1976                           Entity_Id gnat_proc, Entity_Id gnat_pool,
1977                           Node_Id gnat_node)
1978 {
1979   gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
1980
1981   /* Explicit proc to call ?  This one is assumed to deal with the type
1982      alignment constraints.  */
1983   if (Present (gnat_proc))
1984     return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type,
1985                                           gnat_proc, gnat_pool);
1986
1987   /* Otherwise, object to "free" or "malloc" with possible special processing
1988      for alignments stricter than what the default allocator honors.  */
1989   else if (gnu_obj)
1990     return maybe_wrap_free (gnu_obj, gnu_type);
1991   else
1992     {
1993       /* Assert that we no longer can be called with this special pool.  */
1994       gcc_assert (gnat_pool != -1);
1995
1996       /* Check that we aren't violating the associated restriction.  */
1997       if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
1998         Check_No_Implicit_Heap_Alloc (gnat_node);
1999
2000       return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
2001     }
2002 }
2003 \f
2004 /* Build a GCC tree to correspond to allocating an object of TYPE whose
2005    initial value is INIT, if INIT is nonzero.  Convert the expression to
2006    RESULT_TYPE, which must be some type of pointer.  Return the tree.
2007
2008    GNAT_PROC and GNAT_POOL optionally give the procedure to call and
2009    the storage pool to use.  GNAT_NODE is used to provide an error
2010    location for restriction violation messages.  If IGNORE_INIT_TYPE is
2011    true, ignore the type of INIT for the purpose of determining the size;
2012    this will cause the maximum size to be allocated if TYPE is of
2013    self-referential size.  */
2014
2015 tree
2016 build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
2017                  Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
2018 {
2019   tree size = TYPE_SIZE_UNIT (type);
2020   tree result;
2021
2022   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
2023   if (init && TREE_CODE (init) == NULL_EXPR)
2024     return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0));
2025
2026   /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
2027      sizes of the object and its template.  Allocate the whole thing and
2028      fill in the parts that are known.  */
2029   else if (TYPE_IS_FAT_OR_THIN_POINTER_P (result_type))
2030     {
2031       tree storage_type
2032         = build_unc_object_type_from_ptr (result_type, type,
2033                                           get_identifier ("ALLOC"));
2034       tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
2035       tree storage_ptr_type = build_pointer_type (storage_type);
2036       tree storage;
2037       tree template_cons = NULL_TREE;
2038
2039       size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
2040                                              init);
2041
2042       /* If the size overflows, pass -1 so the allocator will raise
2043          storage error.  */
2044       if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
2045         size = ssize_int (-1);
2046
2047       storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type,
2048                                           gnat_proc, gnat_pool, gnat_node);
2049       storage = convert (storage_ptr_type, protect_multiple_eval (storage));
2050
2051       if (TYPE_IS_PADDING_P (type))
2052         {
2053           type = TREE_TYPE (TYPE_FIELDS (type));
2054           if (init)
2055             init = convert (type, init);
2056         }
2057
2058       /* If there is an initializing expression, make a constructor for
2059          the entire object including the bounds and copy it into the
2060          object.  If there is no initializing expression, just set the
2061          bounds.  */
2062       if (init)
2063         {
2064           template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)),
2065                                      init, NULL_TREE);
2066           template_cons = tree_cons (TYPE_FIELDS (storage_type),
2067                                      build_template (template_type, type,
2068                                                      init),
2069                                      template_cons);
2070
2071           return convert
2072             (result_type,
2073              build2 (COMPOUND_EXPR, storage_ptr_type,
2074                      build_binary_op
2075                      (MODIFY_EXPR, storage_type,
2076                       build_unary_op (INDIRECT_REF, NULL_TREE,
2077                                       convert (storage_ptr_type, storage)),
2078                       gnat_build_constructor (storage_type, template_cons)),
2079                      convert (storage_ptr_type, storage)));
2080         }
2081       else
2082         return build2
2083           (COMPOUND_EXPR, result_type,
2084            build_binary_op
2085            (MODIFY_EXPR, template_type,
2086             build_component_ref
2087             (build_unary_op (INDIRECT_REF, NULL_TREE,
2088                              convert (storage_ptr_type, storage)),
2089              NULL_TREE, TYPE_FIELDS (storage_type), 0),
2090             build_template (template_type, type, NULL_TREE)),
2091            convert (result_type, convert (storage_ptr_type, storage)));
2092     }
2093
2094   /* If we have an initializing expression, see if its size is simpler
2095      than the size from the type.  */
2096   if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init))
2097       && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
2098           || CONTAINS_PLACEHOLDER_P (size)))
2099     size = TYPE_SIZE_UNIT (TREE_TYPE (init));
2100
2101   /* If the size is still self-referential, reference the initializing
2102      expression, if it is present.  If not, this must have been a
2103      call to allocate a library-level object, in which case we use
2104      the maximum size.  */
2105   if (CONTAINS_PLACEHOLDER_P (size))
2106     {
2107       if (!ignore_init_type && init)
2108         size = substitute_placeholder_in_expr (size, init);
2109       else
2110         size = max_size (size, true);
2111     }
2112
2113   /* If the size overflows, pass -1 so the allocator will raise
2114      storage error.  */
2115   if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
2116     size = ssize_int (-1);
2117
2118   result = convert (result_type,
2119                     build_call_alloc_dealloc (NULL_TREE, size, type,
2120                                               gnat_proc, gnat_pool,
2121                                               gnat_node));
2122
2123   /* If we have an initial value, put the new address into a SAVE_EXPR, assign
2124      the value, and return the address.  Do this with a COMPOUND_EXPR.  */
2125
2126   if (init)
2127     {
2128       result = save_expr (result);
2129       result
2130         = build2 (COMPOUND_EXPR, TREE_TYPE (result),
2131                   build_binary_op
2132                   (MODIFY_EXPR, NULL_TREE,
2133                    build_unary_op (INDIRECT_REF,
2134                                    TREE_TYPE (TREE_TYPE (result)), result),
2135                    init),
2136                   result);
2137     }
2138
2139   return convert (result_type, result);
2140 }
2141 \f
2142 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
2143    GNAT_FORMAL is how we find the descriptor record.  GNAT_ACTUAL is
2144    how we derive the source location to raise C_E on an out of range
2145    pointer. */
2146
2147 tree
2148 fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
2149 {
2150   tree field;
2151   tree parm_decl = get_gnu_tree (gnat_formal);
2152   tree const_list = NULL_TREE;
2153   tree record_type = TREE_TYPE (TREE_TYPE (parm_decl));
2154   int do_range_check =
2155       strcmp ("MBO",
2156               IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type))));
2157
2158   expr = maybe_unconstrained_array (expr);
2159   gnat_mark_addressable (expr);
2160
2161   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
2162     {
2163       tree conexpr = convert (TREE_TYPE (field),
2164                               SUBSTITUTE_PLACEHOLDER_IN_EXPR
2165                               (DECL_INITIAL (field), expr));
2166
2167       /* Check to ensure that only 32bit pointers are passed in
2168          32bit descriptors */
2169       if (do_range_check &&
2170           strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0)
2171         {
2172           tree pointer64type =
2173              build_pointer_type_for_mode (void_type_node, DImode, false);
2174           tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr);
2175           tree malloc64low =
2176              build_int_cstu (long_integer_type_node, 0x80000000);
2177
2178           add_stmt (build3 (COND_EXPR, void_type_node,
2179                             build_binary_op (GE_EXPR, long_integer_type_node,
2180                                              convert (long_integer_type_node,
2181                                                       addr64expr),
2182                                              malloc64low),
2183                             build_call_raise (CE_Range_Check_Failed, gnat_actual,
2184                                               N_Raise_Constraint_Error),
2185                             NULL_TREE));
2186         }
2187       const_list = tree_cons (field, conexpr, const_list);
2188     }
2189
2190   return gnat_build_constructor (record_type, nreverse (const_list));
2191 }
2192
2193 /* Indicate that we need to make the address of EXPR_NODE and it therefore
2194    should not be allocated in a register.  Returns true if successful.  */
2195
2196 bool
2197 gnat_mark_addressable (tree expr_node)
2198 {
2199   while (1)
2200     switch (TREE_CODE (expr_node))
2201       {
2202       case ADDR_EXPR:
2203       case COMPONENT_REF:
2204       case ARRAY_REF:
2205       case ARRAY_RANGE_REF:
2206       case REALPART_EXPR:
2207       case IMAGPART_EXPR:
2208       case VIEW_CONVERT_EXPR:
2209       case NON_LVALUE_EXPR:
2210       CASE_CONVERT:
2211         expr_node = TREE_OPERAND (expr_node, 0);
2212         break;
2213
2214       case CONSTRUCTOR:
2215         TREE_ADDRESSABLE (expr_node) = 1;
2216         return true;
2217
2218       case VAR_DECL:
2219       case PARM_DECL:
2220       case RESULT_DECL:
2221         TREE_ADDRESSABLE (expr_node) = 1;
2222         return true;
2223
2224       case FUNCTION_DECL:
2225         TREE_ADDRESSABLE (expr_node) = 1;
2226         return true;
2227
2228       case CONST_DECL:
2229         return (DECL_CONST_CORRESPONDING_VAR (expr_node)
2230                 && (gnat_mark_addressable
2231                     (DECL_CONST_CORRESPONDING_VAR (expr_node))));
2232       default:
2233         return true;
2234     }
2235 }