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