gcc/ada/utils2.c

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