gcc/ada/gcc-interface/utils2.c

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