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