gcc/ada/gcc-interface/utils2.c

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