gcc/ada/utils2.c

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