gcc/ada/utils2.c

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