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-2008, 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 "rtl.h"
  32 #include "ggc.h"
  33 #include "flags.h"
  34 #include "output.h"
  35 #include "ada.h"
  36 #include "types.h"
  37 #include "atree.h"
  38 #include "stringt.h"
  39 #include "namet.h"
  40 #include "uintp.h"
  41 #include "fe.h"
  42 #include "elists.h"
  43 #include "nlists.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       /* In these, the result type and the left operand type should be the
 946          same.  Do the operation in the base type of those and convert the
 947          right operand (which is an integer) to that type.
 948
 949          Note that these operations are only used in loop control where
 950          we guarantee that no overflow can occur.  So nothing special need
 951          be done for modular types.  */
 952
 953       gcc_assert (left_type == result_type);
 954       operation_type = get_base_type (result_type);
 955       left_operand = convert (operation_type, left_operand);
 956       right_operand = convert (operation_type, right_operand);
 957       has_side_effects = true;
 958       modulus = NULL_TREE;
 959       break;
 960
 961     case LSHIFT_EXPR:
 962     case RSHIFT_EXPR:
 963     case LROTATE_EXPR:
 964     case RROTATE_EXPR:
 965        /* The RHS of a shift can be any type.  Also, ignore any modulus
 966          (we used to abort, but this is needed for unchecked conversion
 967          to modular types).  Otherwise, processing is the same as normal.  */
 968       gcc_assert (operation_type == left_base_type);
 969       modulus = NULL_TREE;
 970       left_operand = convert (operation_type, left_operand);
 971       break;
 972
 973     case TRUTH_ANDIF_EXPR:
 974     case TRUTH_ORIF_EXPR:
 975     case TRUTH_AND_EXPR:
 976     case TRUTH_OR_EXPR:
 977     case TRUTH_XOR_EXPR:
 978       left_operand = gnat_truthvalue_conversion (left_operand);
 979       right_operand = gnat_truthvalue_conversion (right_operand);
 980       goto common;
 981
 982     case BIT_AND_EXPR:
 983     case BIT_IOR_EXPR:
 984     case BIT_XOR_EXPR:
 985       /* For binary modulus, if the inputs are in range, so are the
 986          outputs.  */
 987       if (modulus && integer_pow2p (modulus))
 988         modulus = NULL_TREE;
 989
 990       goto common;
 991
 992     case COMPLEX_EXPR:
 993       gcc_assert (TREE_TYPE (result_type) == left_base_type
 994                   && TREE_TYPE (result_type) == right_base_type);
 995       left_operand = convert (left_base_type, left_operand);
 996       right_operand = convert (right_base_type, right_operand);
 997       break;
 998
 999     case TRUNC_DIV_EXPR:   case TRUNC_MOD_EXPR:
1000     case CEIL_DIV_EXPR:    case CEIL_MOD_EXPR:
1001     case FLOOR_DIV_EXPR:   case FLOOR_MOD_EXPR:
1002     case ROUND_DIV_EXPR:   case ROUND_MOD_EXPR:
1003       /* These always produce results lower than either operand.  */
1004       modulus = NULL_TREE;
1005       goto common;
1006
1007     case POINTER_PLUS_EXPR:
1008       gcc_assert (operation_type == left_base_type
1009                   && sizetype == right_base_type);
1010       left_operand = convert (operation_type, left_operand);
1011       right_operand = convert (sizetype, right_operand);
1012       break;
1013
1014     default:
1015     common:
1016       /* The result type should be the same as the base types of the
1017          both operands (and they should be the same).  Convert
1018          everything to the result type.  */
1019
1020       gcc_assert (operation_type == left_base_type
1021                   && left_base_type == right_base_type);
1022       left_operand = convert (operation_type, left_operand);
1023       right_operand = convert (operation_type, right_operand);
1024     }
1025
1026   if (modulus && !integer_pow2p (modulus))
1027     {
1028       result = nonbinary_modular_operation (op_code, operation_type,
1029                                             left_operand, right_operand);
1030       modulus = NULL_TREE;
1031     }
1032   /* If either operand is a NULL_EXPR, just return a new one.  */
1033   else if (TREE_CODE (left_operand) == NULL_EXPR)
1034     return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0));
1035   else if (TREE_CODE (right_operand) == NULL_EXPR)
1036     return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
1037   else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
1038     result = fold (build4 (op_code, operation_type, left_operand,
1039                            right_operand, NULL_TREE, NULL_TREE));
1040   else
1041     result
1042       = fold_build2 (op_code, operation_type, left_operand, right_operand);
1043
1044   TREE_SIDE_EFFECTS (result) |= has_side_effects;
1045   TREE_CONSTANT (result)
1046     |= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
1047         && op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF);
1048
1049   if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
1050       && TYPE_VOLATILE (operation_type))
1051     TREE_THIS_VOLATILE (result) = 1;
1052
1053   /* If we are working with modular types, perform the MOD operation
1054      if something above hasn't eliminated the need for it.  */
1055   if (modulus)
1056     result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result,
1057                           convert (operation_type, modulus));
1058
1059   if (result_type && result_type != operation_type)
1060     result = convert (result_type, result);
1061
1062   return result;
1063 }
1064 \f
1065 /* Similar, but for unary operations.  */
1066
1067 tree
1068 build_unary_op (enum tree_code op_code, tree result_type, tree operand)
1069 {
1070   tree type = TREE_TYPE (operand);
1071   tree base_type = get_base_type (type);
1072   tree operation_type = result_type;
1073   tree result;
1074   bool side_effects = false;
1075
1076   if (operation_type
1077       && TREE_CODE (operation_type) == RECORD_TYPE
1078       && TYPE_JUSTIFIED_MODULAR_P (operation_type))
1079     operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
1080
1081   if (operation_type
1082       && !AGGREGATE_TYPE_P (operation_type)
1083       && TYPE_EXTRA_SUBTYPE_P (operation_type))
1084     operation_type = get_base_type (operation_type);
1085
1086   switch (op_code)
1087     {
1088     case REALPART_EXPR:
1089     case IMAGPART_EXPR:
1090       if (!operation_type)
1091         result_type = operation_type = TREE_TYPE (type);
1092       else
1093         gcc_assert (result_type == TREE_TYPE (type));
1094
1095       result = fold_build1 (op_code, operation_type, operand);
1096       break;
1097
1098     case TRUTH_NOT_EXPR:
1099       gcc_assert (result_type == base_type);
1100       result = invert_truthvalue (gnat_truthvalue_conversion (operand));
1101       break;
1102
1103     case ATTR_ADDR_EXPR:
1104     case ADDR_EXPR:
1105       switch (TREE_CODE (operand))
1106         {
1107         case INDIRECT_REF:
1108         case UNCONSTRAINED_ARRAY_REF:
1109           result = TREE_OPERAND (operand, 0);
1110
1111           /* Make sure the type here is a pointer, not a reference.
1112              GCC wants pointer types for function addresses.  */
1113           if (!result_type)
1114             result_type = build_pointer_type (type);
1115
1116           /* If the underlying object can alias everything, propagate the
1117              property since we are effectively retrieving the object.  */
1118           if (POINTER_TYPE_P (TREE_TYPE (result))
1119               && TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result)))
1120             {
1121               if (TREE_CODE (result_type) == POINTER_TYPE
1122                   && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1123                 result_type
1124                   = build_pointer_type_for_mode (TREE_TYPE (result_type),
1125                                                  TYPE_MODE (result_type),
1126                                                  true);
1127               else if (TREE_CODE (result_type) == REFERENCE_TYPE
1128                        && !TYPE_REF_CAN_ALIAS_ALL (result_type))
1129                 result_type
1130                   = build_reference_type_for_mode (TREE_TYPE (result_type),
1131                                                    TYPE_MODE (result_type),
1132                                                    true);
1133             }
1134           break;
1135
1136         case NULL_EXPR:
1137           result = operand;
1138           TREE_TYPE (result) = type = build_pointer_type (type);
1139           break;
1140
1141         case ARRAY_REF:
1142         case ARRAY_RANGE_REF:
1143         case COMPONENT_REF:
1144         case BIT_FIELD_REF:
1145             /* If this is for 'Address, find the address of the prefix and
1146                add the offset to the field.  Otherwise, do this the normal
1147                way.  */
1148           if (op_code == ATTR_ADDR_EXPR)
1149             {
1150               HOST_WIDE_INT bitsize;
1151               HOST_WIDE_INT bitpos;
1152               tree offset, inner;
1153               enum machine_mode mode;
1154               int unsignedp, volatilep;
1155
1156               inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
1157                                            &mode, &unsignedp, &volatilep,
1158                                            false);
1159
1160               /* If INNER is a padding type whose field has a self-referential
1161                  size, convert to that inner type.  We know the offset is zero
1162                  and we need to have that type visible.  */
1163               if (TREE_CODE (TREE_TYPE (inner)) == RECORD_TYPE
1164                   && TYPE_IS_PADDING_P (TREE_TYPE (inner))
1165                   && (CONTAINS_PLACEHOLDER_P
1166                       (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
1167                                              (TREE_TYPE (inner)))))))
1168                 inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
1169                                  inner);
1170
1171               /* Compute the offset as a byte offset from INNER.  */
1172               if (!offset)
1173                 offset = size_zero_node;
1174
1175               if (bitpos % BITS_PER_UNIT != 0)
1176                 post_error
1177                   ("taking address of object not aligned on storage unit?",
1178                    error_gnat_node);
1179
1180               offset = size_binop (PLUS_EXPR, offset,
1181                                    size_int (bitpos / BITS_PER_UNIT));
1182
1183               /* Take the address of INNER, convert the offset to void *, and
1184                  add then.  It will later be converted to the desired result
1185                  type, if any.  */
1186               inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner);
1187               inner = convert (ptr_void_type_node, inner);
1188               result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
1189                                         inner, offset);
1190               result = convert (build_pointer_type (TREE_TYPE (operand)),
1191                                 result);
1192               break;
1193             }
1194           goto common;
1195
1196         case CONSTRUCTOR:
1197           /* If this is just a constructor for a padded record, we can
1198              just take the address of the single field and convert it to
1199              a pointer to our type.  */
1200           if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
1201             {
1202               result = (VEC_index (constructor_elt,
1203                                    CONSTRUCTOR_ELTS (operand),
1204                                    0)
1205                         ->value);
1206
1207               result = convert (build_pointer_type (TREE_TYPE (operand)),
1208                                 build_unary_op (ADDR_EXPR, NULL_TREE, result));
1209               break;
1210             }
1211
1212           goto common;
1213
1214         case NOP_EXPR:
1215           if (AGGREGATE_TYPE_P (type)
1216               && AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0))))
1217             return build_unary_op (ADDR_EXPR, result_type,
1218                                    TREE_OPERAND (operand, 0));
1219
1220           /* ... fallthru ... */
1221
1222         case VIEW_CONVERT_EXPR:
1223           /* If this just a variant conversion or if the conversion doesn't
1224              change the mode, get the result type from this type and go down.
1225              This is needed for conversions of CONST_DECLs, to eventually get
1226              to the address of their CORRESPONDING_VARs.  */
1227           if ((TYPE_MAIN_VARIANT (type)
1228                == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0))))
1229               || (TYPE_MODE (type) != BLKmode
1230                   && (TYPE_MODE (type)
1231                       == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))))
1232             return build_unary_op (ADDR_EXPR,
1233                                    (result_type ? result_type
1234                                     : build_pointer_type (type)),
1235                                    TREE_OPERAND (operand, 0));
1236           goto common;
1237
1238         case CONST_DECL:
1239           operand = DECL_CONST_CORRESPONDING_VAR (operand);
1240
1241           /* ... fall through ... */
1242
1243         default:
1244         common:
1245
1246           /* If we are taking the address of a padded record whose field is
1247              contains a template, take the address of the template.  */
1248           if (TREE_CODE (type) == RECORD_TYPE
1249               && TYPE_IS_PADDING_P (type)
1250               && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
1251               && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
1252             {
1253               type = TREE_TYPE (TYPE_FIELDS (type));
1254               operand = convert (type, operand);
1255             }
1256
1257           if (type != error_mark_node)
1258             operation_type = build_pointer_type (type);
1259
1260           gnat_mark_addressable (operand);
1261           result = fold_build1 (ADDR_EXPR, operation_type, operand);
1262         }
1263
1264       TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
1265       break;
1266
1267     case INDIRECT_REF:
1268       /* If we want to refer to an entire unconstrained array,
1269          make up an expression to do so.  This will never survive to
1270          the backend.  If TYPE is a thin pointer, first convert the
1271          operand to a fat pointer.  */
1272       if (TYPE_THIN_POINTER_P (type)
1273           && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
1274         {
1275           operand
1276             = convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))),
1277                        operand);
1278           type = TREE_TYPE (operand);
1279         }
1280
1281       if (TYPE_FAT_POINTER_P (type))
1282         {
1283           result = build1 (UNCONSTRAINED_ARRAY_REF,
1284                            TYPE_UNCONSTRAINED_ARRAY (type), operand);
1285           TREE_READONLY (result) = TREE_STATIC (result)
1286             = TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type));
1287         }
1288       else if (TREE_CODE (operand) == ADDR_EXPR)
1289         result = TREE_OPERAND (operand, 0);
1290
1291       else
1292         {
1293           result = fold_build1 (op_code, TREE_TYPE (type), operand);
1294           TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type));
1295         }
1296
1297       side_effects
1298         =  (!TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
1299       break;
1300
1301     case NEGATE_EXPR:
1302     case BIT_NOT_EXPR:
1303       {
1304         tree modulus = ((operation_type
1305                          && TREE_CODE (operation_type) == INTEGER_TYPE
1306                          && TYPE_MODULAR_P (operation_type))
1307                         ? TYPE_MODULUS (operation_type) : NULL_TREE);
1308         int mod_pow2 = modulus && integer_pow2p (modulus);
1309
1310         /* If this is a modular type, there are various possibilities
1311            depending on the operation and whether the modulus is a
1312            power of two or not.  */
1313
1314         if (modulus)
1315           {
1316             gcc_assert (operation_type == base_type);
1317             operand = convert (operation_type, operand);
1318
1319             /* The fastest in the negate case for binary modulus is
1320                the straightforward code; the TRUNC_MOD_EXPR below
1321                is an AND operation.  */
1322             if (op_code == NEGATE_EXPR && mod_pow2)
1323               result = fold_build2 (TRUNC_MOD_EXPR, operation_type,
1324                                     fold_build1 (NEGATE_EXPR, operation_type,
1325                                                  operand),
1326                                     modulus);
1327
1328             /* For nonbinary negate case, return zero for zero operand,
1329                else return the modulus minus the operand.  If the modulus
1330                is a power of two minus one, we can do the subtraction
1331                as an XOR since it is equivalent and faster on most machines. */
1332             else if (op_code == NEGATE_EXPR && !mod_pow2)
1333               {
1334                 if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type,
1335                                                 modulus,
1336                                                 convert (operation_type,
1337                                                          integer_one_node))))
1338                   result = fold_build2 (BIT_XOR_EXPR, operation_type,
1339                                         operand, modulus);
1340                 else
1341                   result = fold_build2 (MINUS_EXPR, operation_type,
1342                                         modulus, operand);
1343
1344                 result = fold_build3 (COND_EXPR, operation_type,
1345                                       fold_build2 (NE_EXPR,
1346                                                    integer_type_node,
1347                                                    operand,
1348                                                    convert
1349                                                      (operation_type,
1350                                                       integer_zero_node)),
1351                                       result, operand);
1352               }
1353             else
1354               {
1355                 /* For the NOT cases, we need a constant equal to
1356                    the modulus minus one.  For a binary modulus, we
1357                    XOR against the constant and subtract the operand from
1358                    that constant for nonbinary modulus.  */
1359
1360                 tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus,
1361                                          convert (operation_type,
1362                                                   integer_one_node));
1363
1364                 if (mod_pow2)
1365                   result = fold_build2 (BIT_XOR_EXPR, operation_type,
1366                                         operand, cnst);
1367                 else
1368                   result = fold_build2 (MINUS_EXPR, operation_type,
1369                                         cnst, operand);
1370               }
1371
1372             break;
1373           }
1374       }
1375
1376       /* ... fall through ... */
1377
1378     default:
1379       gcc_assert (operation_type == base_type);
1380       result = fold_build1 (op_code, operation_type,
1381                             convert (operation_type, operand));
1382     }
1383
1384   if (side_effects)
1385     {
1386       TREE_SIDE_EFFECTS (result) = 1;
1387       if (TREE_CODE (result) == INDIRECT_REF)
1388         TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
1389     }
1390
1391   if (result_type && TREE_TYPE (result) != result_type)
1392     result = convert (result_type, result);
1393
1394   return result;
1395 }
1396 \f
1397 /* Similar, but for COND_EXPR.  */
1398
1399 tree
1400 build_cond_expr (tree result_type, tree condition_operand,
1401                  tree true_operand, tree false_operand)
1402 {
1403   tree result;
1404   bool addr_p = false;
1405
1406   /* The front-end verifies that result, true and false operands have same base
1407      type.  Convert everything to the result type.  */
1408
1409   true_operand  = convert (result_type, true_operand);
1410   false_operand = convert (result_type, false_operand);
1411
1412   /* If the result type is unconstrained, take the address of
1413      the operands and then dereference our result.  */
1414   if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
1415       || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
1416     {
1417       addr_p = true;
1418       result_type = build_pointer_type (result_type);
1419       true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand);
1420       false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
1421     }
1422
1423   result = fold_build3 (COND_EXPR, result_type, condition_operand,
1424                         true_operand, false_operand);
1425
1426   /* If either operand is a SAVE_EXPR (possibly surrounded by
1427      arithmetic, make sure it gets done.  */
1428   true_operand  = skip_simple_arithmetic (true_operand);
1429   false_operand = skip_simple_arithmetic (false_operand);
1430
1431   if (TREE_CODE (true_operand) == SAVE_EXPR)
1432     result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
1433
1434   if (TREE_CODE (false_operand) == SAVE_EXPR)
1435     result = build2 (COMPOUND_EXPR, result_type, false_operand, result);
1436
1437   /* ??? Seems the code above is wrong, as it may move ahead of the COND
1438      SAVE_EXPRs with side effects and not shared by both arms.  */
1439
1440  if (addr_p)
1441     result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
1442
1443   return result;
1444 }
1445
1446 /* Similar, but for RETURN_EXPR.  If RESULT_DECL is non-zero, build
1447    a RETURN_EXPR around the assignment of RET_VAL to RESULT_DECL.
1448    If RESULT_DECL is zero, build a bare RETURN_EXPR.  */
1449
1450 tree
1451 build_return_expr (tree result_decl, tree ret_val)
1452 {
1453   tree result_expr;
1454
1455   if (result_decl)
1456     {
1457       /* The gimplifier explicitly enforces the following invariant:
1458
1459            RETURN_EXPR
1460                |
1461            MODIFY_EXPR
1462            /        \
1463           /          \
1464       RESULT_DECL    ...
1465
1466       As a consequence, type-homogeneity dictates that we use the type
1467       of the RESULT_DECL as the operation type.  */
1468
1469       tree operation_type = TREE_TYPE (result_decl);
1470
1471       /* Convert the right operand to the operation type.  Note that
1472          it's the same transformation as in the MODIFY_EXPR case of
1473          build_binary_op with the additional guarantee that the type
1474          cannot involve a placeholder, since otherwise the function
1475          would use the "target pointer" return mechanism.  */
1476
1477       if (operation_type != TREE_TYPE (ret_val))
1478         ret_val = convert (operation_type, ret_val);
1479
1480       result_expr
1481         = build2 (MODIFY_EXPR, operation_type, result_decl, ret_val);
1482     }
1483   else
1484     result_expr = NULL_TREE;
1485
1486   return build1 (RETURN_EXPR, void_type_node, result_expr);
1487 }
1488 \f
1489 /* Build a CALL_EXPR to call FUNDECL with one argument, ARG.  Return
1490    the CALL_EXPR.  */
1491
1492 tree
1493 build_call_1_expr (tree fundecl, tree arg)
1494 {
1495   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1496                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1497                                1, arg);
1498   TREE_SIDE_EFFECTS (call) = 1;
1499   return call;
1500 }
1501
1502 /* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2.  Return
1503    the CALL_EXPR.  */
1504
1505 tree
1506 build_call_2_expr (tree fundecl, tree arg1, tree arg2)
1507 {
1508   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1509                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1510                                2, arg1, arg2);
1511   TREE_SIDE_EFFECTS (call) = 1;
1512   return call;
1513 }
1514
1515 /* Likewise to call FUNDECL with no arguments.  */
1516
1517 tree
1518 build_call_0_expr (tree fundecl)
1519 {
1520   /* We rely on build_call_nary to compute TREE_SIDE_EFFECTS.  This makes
1521      it possible to propagate DECL_IS_PURE on parameterless functions.  */
1522   tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
1523                                build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1524                                0);
1525   return call;
1526 }
1527 \f
1528 /* Call a function that raises an exception and pass the line number and file
1529    name, if requested.  MSG says which exception function to call.
1530
1531    GNAT_NODE is the gnat node conveying the source location for which the
1532    error should be signaled, or Empty in which case the error is signaled on
1533    the current ref_file_name/input_line.
1534
1535    KIND says which kind of exception this is for
1536    (N_Raise_{Constraint,Storage,Program}_Error).  */
1537
1538 tree
1539 build_call_raise (int msg, Node_Id gnat_node, char kind)
1540 {
1541   tree fndecl = gnat_raise_decls[msg];
1542   tree label = get_exception_label (kind);
1543   tree filename;
1544   int line_number;
1545   const char *str;
1546   int len;
1547
1548   /* If this is to be done as a goto, handle that case.  */
1549   if (label)
1550     {
1551       Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
1552       tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
1553
1554       /* If Local_Raise is present, generate
1555          Local_Raise (exception'Identity);  */
1556       if (Present (local_raise))
1557         {
1558           tree gnu_local_raise
1559             = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
1560           tree gnu_exception_entity
1561             = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
1562           tree gnu_call
1563             = build_call_1_expr (gnu_local_raise,
1564                                  build_unary_op (ADDR_EXPR, NULL_TREE,
1565                                                  gnu_exception_entity));
1566
1567           gnu_result = build2 (COMPOUND_EXPR, void_type_node,
1568                                gnu_call, gnu_result);}
1569
1570       return gnu_result;
1571     }
1572
1573   str
1574     = (Debug_Flag_NN || Exception_Locations_Suppressed)
1575       ? ""
1576       : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1577         ? IDENTIFIER_POINTER
1578           (get_identifier (Get_Name_String
1579                            (Debug_Source_Name
1580                             (Get_Source_File_Index (Sloc (gnat_node))))))
1581         : ref_filename;
1582
1583   len = strlen (str) + 1;
1584   filename = build_string (len, str);
1585   line_number
1586     = (gnat_node != Empty && Sloc (gnat_node) != No_Location)
1587       ? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
1588
1589   TREE_TYPE (filename)
1590     = build_array_type (char_type_node,
1591                         build_index_type (build_int_cst (NULL_TREE, len)));
1592
1593   return
1594     build_call_2_expr (fndecl,
1595                        build1 (ADDR_EXPR, build_pointer_type (char_type_node),
1596                                filename),
1597                        build_int_cst (NULL_TREE, line_number));
1598 }
1599 \f
1600 /* qsort comparer for the bit positions of two constructor elements
1601    for record components.  */
1602
1603 static int
1604 compare_elmt_bitpos (const PTR rt1, const PTR rt2)
1605 {
1606   const_tree const elmt1 = * (const_tree const *) rt1;
1607   const_tree const elmt2 = * (const_tree const *) rt2;
1608   const_tree const field1 = TREE_PURPOSE (elmt1);
1609   const_tree const field2 = TREE_PURPOSE (elmt2);
1610   const int ret
1611     = tree_int_cst_compare (bit_position (field1), bit_position (field2));
1612
1613   return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
1614 }
1615
1616 /* Return a CONSTRUCTOR of TYPE whose list is LIST.  */
1617
1618 tree
1619 gnat_build_constructor (tree type, tree list)
1620 {
1621   tree elmt;
1622   int n_elmts;
1623   bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
1624   bool side_effects = false;
1625   tree result;
1626
1627   /* Scan the elements to see if they are all constant or if any has side
1628      effects, to let us set global flags on the resulting constructor.  Count
1629      the elements along the way for possible sorting purposes below.  */
1630   for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++)
1631     {
1632       if (!TREE_CONSTANT (TREE_VALUE (elmt))
1633           || (TREE_CODE (type) == RECORD_TYPE
1634               && DECL_BIT_FIELD (TREE_PURPOSE (elmt))
1635               && TREE_CODE (TREE_VALUE (elmt)) != INTEGER_CST)
1636           || !initializer_constant_valid_p (TREE_VALUE (elmt),
1637                                             TREE_TYPE (TREE_VALUE (elmt))))
1638         allconstant = false;
1639
1640       if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt)))
1641         side_effects = true;
1642
1643       /* Propagate an NULL_EXPR from the size of the type.  We won't ever
1644          be executing the code we generate here in that case, but handle it
1645          specially to avoid the compiler blowing up.  */
1646       if (TREE_CODE (type) == RECORD_TYPE
1647           && (0 != (result
1648                     = contains_null_expr (DECL_SIZE (TREE_PURPOSE (elmt))))))
1649         return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0));
1650     }
1651
1652   /* For record types with constant components only, sort field list
1653      by increasing bit position.  This is necessary to ensure the
1654      constructor can be output as static data.  */
1655   if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
1656     {
1657       /* Fill an array with an element tree per index, and ask qsort to order
1658          them according to what a bitpos comparison function says.  */
1659       tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
1660       int i;
1661
1662       for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++)
1663         gnu_arr[i] = elmt;
1664
1665       qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
1666
1667       /* Then reconstruct the list from the sorted array contents.  */
1668       list = NULL_TREE;
1669       for (i = n_elmts - 1; i >= 0; i--)
1670         {
1671           TREE_CHAIN (gnu_arr[i]) = list;
1672           list = gnu_arr[i];
1673         }
1674     }
1675
1676   result = build_constructor_from_list (type, list);
1677   TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant;
1678   TREE_SIDE_EFFECTS (result) = side_effects;
1679   TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
1680   return result;
1681 }
1682 \f
1683 /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
1684    an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
1685    for the field.  Don't fold the result if NO_FOLD_P is true.
1686
1687    We also handle the fact that we might have been passed a pointer to the
1688    actual record and know how to look for fields in variant parts.  */
1689
1690 static tree
1691 build_simple_component_ref (tree record_variable, tree component,
1692                             tree field, bool no_fold_p)
1693 {
1694   tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
1695   tree ref, inner_variable;
1696
1697   gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE
1698                || TREE_CODE (record_type) == UNION_TYPE
1699                || TREE_CODE (record_type) == QUAL_UNION_TYPE)
1700               && TYPE_SIZE (record_type)
1701               && (component != 0) != (field != 0));
1702
1703   /* If no field was specified, look for a field with the specified name
1704      in the current record only.  */
1705   if (!field)
1706     for (field = TYPE_FIELDS (record_type); field;
1707          field = TREE_CHAIN (field))
1708       if (DECL_NAME (field) == component)
1709         break;
1710
1711   if (!field)
1712     return NULL_TREE;
1713
1714   /* If this field is not in the specified record, see if we can find
1715      something in the record whose original field is the same as this one. */
1716   if (DECL_CONTEXT (field) != record_type)
1717     /* Check if there is a field with name COMPONENT in the record.  */
1718     {
1719       tree new_field;
1720
1721       /* First loop thru normal components.  */
1722
1723       for (new_field = TYPE_FIELDS (record_type); new_field;
1724            new_field = TREE_CHAIN (new_field))
1725         if (field == new_field
1726             || DECL_ORIGINAL_FIELD (new_field) == field
1727             || new_field == DECL_ORIGINAL_FIELD (field)
1728             || (DECL_ORIGINAL_FIELD (field)
1729                 && (DECL_ORIGINAL_FIELD (field)
1730                     == DECL_ORIGINAL_FIELD (new_field))))
1731           break;
1732
1733       /* Next, loop thru DECL_INTERNAL_P components if we haven't found
1734          the component in the first search. Doing this search in 2 steps
1735          is required to avoiding hidden homonymous fields in the
1736          _Parent field.  */
1737
1738       if (!new_field)
1739         for (new_field = TYPE_FIELDS (record_type); new_field;
1740              new_field = TREE_CHAIN (new_field))
1741           if (DECL_INTERNAL_P (new_field))
1742             {
1743               tree field_ref
1744                 = build_simple_component_ref (record_variable,
1745                                               NULL_TREE, new_field, no_fold_p);
1746               ref = build_simple_component_ref (field_ref, NULL_TREE, field,
1747                                                 no_fold_p);
1748
1749               if (ref)
1750                 return ref;
1751             }
1752
1753       field = new_field;
1754     }
1755
1756   if (!field)
1757     return NULL_TREE;
1758
1759   /* If the field's offset has overflowed, do not attempt to access it
1760      as doing so may trigger sanity checks deeper in the back-end.
1761      Note that we don't need to warn since this will be done on trying
1762      to declare the object.  */
1763   if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST
1764       && TREE_OVERFLOW (DECL_FIELD_OFFSET (field)))
1765     return NULL_TREE;
1766
1767   /* Look through conversion between type variants.  Note that this
1768      is transparent as far as the field is concerned.  */
1769   if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
1770       && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
1771          == record_type)
1772     inner_variable = TREE_OPERAND (record_variable, 0);
1773   else
1774     inner_variable = record_variable;
1775
1776   ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field,
1777                 NULL_TREE);
1778
1779   if (TREE_READONLY (record_variable) || TREE_READONLY (field))
1780     TREE_READONLY (ref) = 1;
1781   if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
1782       || TYPE_VOLATILE (record_type))
1783     TREE_THIS_VOLATILE (ref) = 1;
1784
1785   if (no_fold_p)
1786     return ref;
1787
1788   /* The generic folder may punt in this case because the inner array type
1789      can be self-referential, but folding is in fact not problematic.  */
1790   else if (TREE_CODE (record_variable) == CONSTRUCTOR
1791            && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable)))
1792     {
1793       VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable);
1794       unsigned HOST_WIDE_INT idx;
1795       tree index, value;
1796       FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
1797         if (index == field)
1798           return value;
1799       return ref;
1800     }
1801
1802   else
1803     return fold (ref);
1804 }
1805 \f
1806 /* Like build_simple_component_ref, except that we give an error if the
1807    reference could not be found.  */
1808
1809 tree
1810 build_component_ref (tree record_variable, tree component,
1811                      tree field, bool no_fold_p)
1812 {
1813   tree ref = build_simple_component_ref (record_variable, component, field,
1814                                          no_fold_p);
1815
1816   if (ref)
1817     return ref;
1818
1819   /* If FIELD was specified, assume this is an invalid user field so
1820      raise constraint error.  Otherwise, we can't find the type to return, so
1821      abort.  */
1822   gcc_assert (field);
1823   return build1 (NULL_EXPR, TREE_TYPE (field),
1824                  build_call_raise (CE_Discriminant_Check_Failed, Empty,
1825                                    N_Raise_Constraint_Error));
1826 }
1827 \f
1828 /* Build a GCC tree to call an allocation or deallocation function.
1829    If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
1830    generate an allocator.
1831
1832    GNU_SIZE is the size of the object in bytes and ALIGN is the alignment in
1833    bits.  GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the
1834    storage pool to use.  If not preset, malloc and free will be used except
1835    if GNAT_PROC is the "fake" value of -1, in which case we allocate the
1836    object dynamically on the stack frame.  */
1837
1838 tree
1839 build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
1840                           Entity_Id gnat_proc, Entity_Id gnat_pool,
1841                           Node_Id gnat_node)
1842 {
1843   tree gnu_align = size_int (align / BITS_PER_UNIT);
1844
1845   gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
1846
1847   if (Present (gnat_proc))
1848     {
1849       /* The storage pools are obviously always tagged types, but the
1850          secondary stack uses the same mechanism and is not tagged */
1851       if (Is_Tagged_Type (Etype (gnat_pool)))
1852         {
1853           /* The size is the third parameter; the alignment is the
1854              same type.  */
1855           Entity_Id gnat_size_type
1856             = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
1857           tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1858           tree gnu_proc = gnat_to_gnu (gnat_proc);
1859           tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
1860           tree gnu_pool = gnat_to_gnu (gnat_pool);
1861           tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
1862           tree gnu_call;
1863
1864           gnu_size = convert (gnu_size_type, gnu_size);
1865           gnu_align = convert (gnu_size_type, gnu_align);
1866
1867           /* The first arg is always the address of the storage pool; next
1868              comes the address of the object, for a deallocator, then the
1869              size and alignment.  */
1870           if (gnu_obj)
1871             gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1872                                         gnu_proc_addr, 4, gnu_pool_addr,
1873                                         gnu_obj, gnu_size, gnu_align);
1874           else
1875             gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1876                                         gnu_proc_addr, 3, gnu_pool_addr,
1877                                         gnu_size, gnu_align);
1878           TREE_SIDE_EFFECTS (gnu_call) = 1;
1879           return gnu_call;
1880         }
1881
1882       /* Secondary stack case.  */
1883       else
1884         {
1885           /* The size is the second parameter */
1886           Entity_Id gnat_size_type
1887             = Etype (Next_Formal (First_Formal (gnat_proc)));
1888           tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
1889           tree gnu_proc = gnat_to_gnu (gnat_proc);
1890           tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
1891           tree gnu_call;
1892
1893           gnu_size = convert (gnu_size_type, gnu_size);
1894
1895           /* The first arg is the address of the object, for a
1896              deallocator, then the size */
1897           if (gnu_obj)
1898             gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1899                                         gnu_proc_addr, 2, gnu_obj, gnu_size);
1900           else
1901             gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
1902                                         gnu_proc_addr, 1, gnu_size);
1903           TREE_SIDE_EFFECTS (gnu_call) = 1;
1904           return gnu_call;
1905         }
1906     }
1907
1908   else if (gnu_obj)
1909     return build_call_1_expr (free_decl, gnu_obj);
1910
1911   /* ??? For now, disable variable-sized allocators in the stack since
1912      we can't yet gimplify an ALLOCATE_EXPR.  */
1913   else if (gnat_pool == -1
1914            && TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check)
1915     {
1916       /* If the size is a constant, we can put it in the fixed portion of
1917          the stack frame to avoid the need to adjust the stack pointer.  */
1918       if (TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check)
1919         {
1920           tree gnu_range
1921             = build_range_type (NULL_TREE, size_one_node, gnu_size);
1922           tree gnu_array_type = build_array_type (char_type_node, gnu_range);
1923           tree gnu_decl
1924             = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
1925                                gnu_array_type, NULL_TREE, false, false, false,
1926                                false, NULL, gnat_node);
1927
1928           return convert (ptr_void_type_node,
1929                           build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl));
1930         }
1931       else
1932         gcc_unreachable ();
1933 #if 0
1934         return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
1935 #endif
1936     }
1937   else
1938     {
1939       if (Nkind (gnat_node) != N_Allocator || !Comes_From_Source (gnat_node))
1940         Check_No_Implicit_Heap_Alloc (gnat_node);
1941
1942       /* If the allocator size is 32bits but the pointer size is 64bits then
1943          allocate 32bit memory (sometimes necessary on 64bit VMS). Otherwise
1944          default to standard malloc. */
1945       if (UI_To_Int (Esize (Etype (gnat_node))) == 32 && POINTER_SIZE == 64)
1946         return build_call_1_expr (malloc32_decl, gnu_size);
1947       else
1948         return build_call_1_expr (malloc_decl, gnu_size);
1949     }
1950 }
1951 \f
1952 /* Build a GCC tree to correspond to allocating an object of TYPE whose
1953    initial value is INIT, if INIT is nonzero.  Convert the expression to
1954    RESULT_TYPE, which must be some type of pointer.  Return the tree.
1955    GNAT_PROC and GNAT_POOL optionally give the procedure to call and
1956    the storage pool to use.  GNAT_NODE is used to provide an error
1957    location for restriction violations messages.  If IGNORE_INIT_TYPE is
1958    true, ignore the type of INIT for the purpose of determining the size;
1959    this will cause the maximum size to be allocated if TYPE is of
1960    self-referential size.  */
1961
1962 tree
1963 build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
1964                  Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
1965 {
1966   tree size = TYPE_SIZE_UNIT (type);
1967   tree result;
1968   unsigned int default_allocator_alignment
1969     = get_target_default_allocator_alignment () * BITS_PER_UNIT;
1970
1971   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
1972   if (init && TREE_CODE (init) == NULL_EXPR)
1973     return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0));
1974
1975   /* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
1976      sizes of the object and its template.  Allocate the whole thing and
1977      fill in the parts that are known.  */
1978   else if (TYPE_FAT_OR_THIN_POINTER_P (result_type))
1979     {
1980       tree storage_type
1981         = build_unc_object_type_from_ptr (result_type, type,
1982                                           get_identifier ("ALLOC"));
1983       tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
1984       tree storage_ptr_type = build_pointer_type (storage_type);
1985       tree storage;
1986       tree template_cons = NULL_TREE;
1987
1988       size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
1989                                              init);
1990
1991       /* If the size overflows, pass -1 so the allocator will raise
1992          storage error.  */
1993       if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
1994         size = ssize_int (-1);
1995
1996       storage = build_call_alloc_dealloc (NULL_TREE, size,
1997                                           TYPE_ALIGN (storage_type),
1998                                           gnat_proc, gnat_pool, gnat_node);
1999       storage = convert (storage_ptr_type, protect_multiple_eval (storage));
2000
2001       if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
2002         {
2003           type = TREE_TYPE (TYPE_FIELDS (type));
2004
2005           if (init)
2006             init = convert (type, init);
2007         }
2008
2009       /* If there is an initializing expression, make a constructor for
2010          the entire object including the bounds and copy it into the
2011          object.  If there is no initializing expression, just set the
2012          bounds.  */
2013       if (init)
2014         {
2015           template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)),
2016                                      init, NULL_TREE);
2017           template_cons = tree_cons (TYPE_FIELDS (storage_type),
2018                                      build_template (template_type, type,
2019                                                      init),
2020                                      template_cons);
2021
2022           return convert
2023             (result_type,
2024              build2 (COMPOUND_EXPR, storage_ptr_type,
2025                      build_binary_op
2026                      (MODIFY_EXPR, storage_type,
2027                       build_unary_op (INDIRECT_REF, NULL_TREE,
2028                                       convert (storage_ptr_type, storage)),
2029                       gnat_build_constructor (storage_type, template_cons)),
2030                      convert (storage_ptr_type, storage)));
2031         }
2032       else
2033         return build2
2034           (COMPOUND_EXPR, result_type,
2035            build_binary_op
2036            (MODIFY_EXPR, template_type,
2037             build_component_ref
2038             (build_unary_op (INDIRECT_REF, NULL_TREE,
2039                              convert (storage_ptr_type, storage)),
2040              NULL_TREE, TYPE_FIELDS (storage_type), 0),
2041             build_template (template_type, type, NULL_TREE)),
2042            convert (result_type, convert (storage_ptr_type, storage)));
2043     }
2044
2045   /* If we have an initializing expression, see if its size is simpler
2046      than the size from the type.  */
2047   if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init))
2048       && (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
2049           || CONTAINS_PLACEHOLDER_P (size)))
2050     size = TYPE_SIZE_UNIT (TREE_TYPE (init));
2051
2052   /* If the size is still self-referential, reference the initializing
2053      expression, if it is present.  If not, this must have been a
2054      call to allocate a library-level object, in which case we use
2055      the maximum size.  */
2056   if (CONTAINS_PLACEHOLDER_P (size))
2057     {
2058       if (!ignore_init_type && init)
2059         size = substitute_placeholder_in_expr (size, init);
2060       else
2061         size = max_size (size, true);
2062     }
2063
2064   /* If the size overflows, pass -1 so the allocator will raise
2065      storage error.  */
2066   if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
2067     size = ssize_int (-1);
2068
2069   /* If this is in the default storage pool and the type alignment is larger
2070      than what the default allocator supports, make an "aligning" record type
2071      with room to store a pointer before the field, allocate an object of that
2072      type, store the system's allocator return value just in front of the
2073      field and return the field's address.  */
2074
2075   if (No (gnat_proc) && TYPE_ALIGN (type) > default_allocator_alignment)
2076     {
2077       /* Construct the aligning type with enough room for a pointer ahead
2078          of the field, then allocate.  */
2079       tree record_type
2080         = make_aligning_type (type, TYPE_ALIGN (type), size,
2081                               default_allocator_alignment,
2082                               POINTER_SIZE / BITS_PER_UNIT);
2083
2084       tree record, record_addr;
2085
2086       record_addr
2087         = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type),
2088                                     default_allocator_alignment, Empty, Empty,
2089                                     gnat_node);
2090
2091       record_addr
2092         = convert (build_pointer_type (record_type),
2093                    save_expr (record_addr));
2094
2095       record = build_unary_op (INDIRECT_REF, NULL_TREE, record_addr);
2096
2097       /* Our RESULT (the Ada allocator's value) is the super-aligned address
2098          of the internal record field ... */
2099       result
2100         = build_unary_op (ADDR_EXPR, NULL_TREE,
2101                           build_component_ref
2102                           (record, NULL_TREE, TYPE_FIELDS (record_type), 0));
2103       result = convert (result_type, result);
2104
2105       /* ... with the system allocator's return value stored just in
2106          front.  */
2107       {
2108         tree ptr_addr
2109           = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
2110                              convert (ptr_void_type_node, result),
2111                              size_int (-POINTER_SIZE/BITS_PER_UNIT));
2112
2113         tree ptr_ref
2114           = convert (build_pointer_type (ptr_void_type_node), ptr_addr);
2115
2116         result
2117           = build2 (COMPOUND_EXPR, TREE_TYPE (result),
2118                     build_binary_op (MODIFY_EXPR, NULL_TREE,
2119                                      build_unary_op (INDIRECT_REF, NULL_TREE,
2120                                                      ptr_ref),
2121                                      convert (ptr_void_type_node,
2122                                               record_addr)),
2123                     result);
2124       }
2125     }
2126   else
2127     result = convert (result_type,
2128                       build_call_alloc_dealloc (NULL_TREE, size,
2129                                                 TYPE_ALIGN (type),
2130                                                 gnat_proc,
2131                                                 gnat_pool,
2132                                                 gnat_node));
2133
2134   /* If we have an initial value, put the new address into a SAVE_EXPR, assign
2135      the value, and return the address.  Do this with a COMPOUND_EXPR.  */
2136
2137   if (init)
2138     {
2139       result = save_expr (result);
2140       result
2141         = build2 (COMPOUND_EXPR, TREE_TYPE (result),
2142                   build_binary_op
2143                   (MODIFY_EXPR, NULL_TREE,
2144                    build_unary_op (INDIRECT_REF,
2145                                    TREE_TYPE (TREE_TYPE (result)), result),
2146                    init),
2147                   result);
2148     }
2149
2150   return convert (result_type, result);
2151 }
2152 \f
2153 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
2154    GNAT_FORMAL is how we find the descriptor record.  GNAT_ACTUAL is
2155    how we find the allocator size which determines whether to use the
2156    alternate 64bit descriptor. */
2157
2158 tree
2159 fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
2160 {
2161   tree field;
2162   tree parm_decl = get_gnu_tree (gnat_formal);
2163   tree const_list = NULL_TREE;
2164   int size;
2165   tree record_type;
2166
2167   /* A string literal will always be in 32bit space on VMS. Where
2168      will it be on other 64bit systems???
2169      An identifier's allocation may be unknown at compile time.
2170      An explicit dereference could be either in 32bit or 64bit space.
2171      Don't know about other possibilities, so assume unknown which
2172      will result in fetching the 64bit descriptor. ??? */
2173   if (Nkind (gnat_actual) == N_String_Literal)
2174     size = 32;
2175   else if (Nkind (gnat_actual) == N_Identifier)
2176     size = UI_To_Int (Esize (Etype (gnat_actual)));
2177   else if (Nkind (gnat_actual) == N_Explicit_Dereference)
2178     size = UI_To_Int (Esize (Etype (Prefix (gnat_actual))));
2179   else
2180     size = 0;
2181
2182   /* If size is unknown, make it POINTER_SIZE */
2183   if (size == 0)
2184     size = POINTER_SIZE;
2185
2186   /* If size is 64bits grab the alternate 64bit descriptor. */
2187   if (size == 64)
2188     TREE_TYPE (parm_decl) = DECL_PARM_ALT (parm_decl);
2189
2190   record_type = TREE_TYPE (TREE_TYPE (parm_decl));
2191   expr = maybe_unconstrained_array (expr);
2192   gnat_mark_addressable (expr);
2193
2194   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
2195     const_list
2196       = tree_cons (field,
2197                    convert (TREE_TYPE (field),
2198                             SUBSTITUTE_PLACEHOLDER_IN_EXPR
2199                             (DECL_INITIAL (field), expr)),
2200                    const_list);
2201
2202   return gnat_build_constructor (record_type, nreverse (const_list));
2203 }
2204
2205 /* Indicate that we need to make the address of EXPR_NODE and it therefore
2206    should not be allocated in a register.  Returns true if successful.  */
2207
2208 bool
2209 gnat_mark_addressable (tree expr_node)
2210 {
2211   while (1)
2212     switch (TREE_CODE (expr_node))
2213       {
2214       case ADDR_EXPR:
2215       case COMPONENT_REF:
2216       case ARRAY_REF:
2217       case ARRAY_RANGE_REF:
2218       case REALPART_EXPR:
2219       case IMAGPART_EXPR:
2220       case VIEW_CONVERT_EXPR:
2221       case NON_LVALUE_EXPR:
2222       CASE_CONVERT:
2223         expr_node = TREE_OPERAND (expr_node, 0);
2224         break;
2225
2226       case CONSTRUCTOR:
2227         TREE_ADDRESSABLE (expr_node) = 1;
2228         return true;
2229
2230       case VAR_DECL:
2231       case PARM_DECL:
2232       case RESULT_DECL:
2233         TREE_ADDRESSABLE (expr_node) = 1;
2234         return true;
2235
2236       case FUNCTION_DECL:
2237         TREE_ADDRESSABLE (expr_node) = 1;
2238         return true;
2239
2240       case CONST_DECL:
2241         return (DECL_CONST_CORRESPONDING_VAR (expr_node)
2242                 && (gnat_mark_addressable
2243                     (DECL_CONST_CORRESPONDING_VAR (expr_node))));
2244       default:
2245         return true;
2246     }
2247 }