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