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