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