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