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