gcc/ada/gcc-interface/utils2.c

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