gcc/ada/gcc-interface/utils2.c

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