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