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