home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / a-trans4.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  39KB  |  1,224 lines
  1. /****************************************************************************/
  2. /*                                                                          */
  3. /*                         GNAT COMPILER COMPONENTS                         */
  4. /*                                                                          */
  5. /*                             A - T R A N S 4                              */
  6. /*                                                                          */
  7. /*                          C Implementation File                           */
  8. /*                                                                          */
  9. /*                            $Revision: 1.99 $                             */
  10. /*                                                                          */
  11. /*           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          */
  12. /*                                                                          */
  13. /* GNAT is free software;  you can  redistribute it  and/or modify it under */
  14. /* terms of the  GNU General Public License as published  by the Free Soft- */
  15. /* ware  Foundation;  either version 2,  or (at your option) any later ver- */
  16. /* sion.  GNAT is distributed in the hope that it will be useful, but WITH- */
  17. /* OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY */
  18. /* or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License */
  19. /* for  more details.  You should have  received  a copy of the GNU General */
  20. /* Public License  distributed with GNAT;  see file COPYING.  If not, write */
  21. /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
  22. /*                                                                          */
  23. /****************************************************************************/
  24.  
  25. #include "config.h"
  26. #include "tree.h"
  27. #include "flags.h"
  28. #include "a-ada.h"
  29. #include "a-types.h"
  30. #include "a-atree.h"
  31. #include "a-nlists.h"
  32. #include "a-elists.h"
  33. #include "a-sinfo.h"
  34. #include "a-einfo.h"
  35. #include "a-namet.h"
  36. #include "a-snames.h"
  37. #include "a-string.h"
  38. #include "a-uintp.h"
  39. #include "a-gtran3.h"
  40. #include "a-trans.h"
  41. #include "a-trans3.h"
  42. #include "a-trans4.h"
  43. #include "a-misc.h"
  44.  
  45. static tree find_common_type        PROTO((tree, tree));
  46. static tree compare_arrays        PROTO((tree, tree, tree));
  47. static tree nonbinary_modular_operation    PROTO((enum tree_code, tree,
  48.                            tree, tree));
  49.  
  50. /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
  51.    operation.
  52.  
  53.    This preparation consists of taking the ordinary
  54.    representation of an expression expr and producing a valid tree
  55.    boolean expression describing whether expr is nonzero.  We could
  56.    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
  57.    but we optimize comparisons, &&, ||, and !.
  58.  
  59.    The resulting type should always be the same as the input type.
  60.    This function is simpler than the corresponding C version since
  61.    the only possible operands will be things of Boolean type.  */
  62.  
  63. tree
  64. truthvalue_conversion (expr)
  65.      tree expr;
  66. {
  67.   register enum tree_code code;
  68.   tree type = TREE_TYPE (expr);
  69.  
  70.   switch (TREE_CODE (expr))
  71.     {
  72.     case EQ_EXPR:  case NE_EXPR: case LE_EXPR: case GE_EXPR:
  73.     case LT_EXPR:  case GT_EXPR:
  74.     case TRUTH_ANDIF_EXPR:
  75.     case TRUTH_ORIF_EXPR:
  76.     case TRUTH_AND_EXPR:
  77.     case TRUTH_OR_EXPR:
  78.     case TRUTH_XOR_EXPR:
  79.     case ERROR_MARK:
  80.       return expr;
  81.  
  82.     case COND_EXPR:
  83.       /* Distribute the conversion into the arms of a COND_EXPR.  */
  84.       return fold (build (COND_EXPR, type, TREE_OPERAND (expr, 0),
  85.               truthvalue_conversion (TREE_OPERAND (expr, 1)),
  86.               truthvalue_conversion (TREE_OPERAND (expr, 2))));
  87.     }
  88.  
  89.   return build_binary_op (NE_EXPR, type, expr,
  90.               convert (type, integer_zero_node));
  91. }
  92.  
  93. /* Return the base type of TYPE.  */
  94.  
  95. tree
  96. get_base_type (type)
  97.      tree type;
  98. {
  99.   while (TREE_TYPE (type) != 0
  100.      && (TREE_CODE (type) == INTEGER_TYPE
  101.          || TREE_CODE (type) == REAL_TYPE))
  102.     type = TREE_TYPE (type);
  103.  
  104.   return type;
  105. }
  106.  
  107. /* We have a comparison or assignment operation on two types, T1 and T2,
  108.    which are both either array types or both record types.
  109.    Return the type that both operands should be converted to, if any.
  110.    Otherwise return zero.  */
  111.  
  112. static tree
  113. find_common_type (t1, t2)
  114.      tree t1, t2;
  115. {
  116.   /* If either type is non-BLKmode, use it.  Note that we know that we will
  117.      not have any alignment problems since if we did the non-BLKmode
  118.      type could not have been used.  */
  119.   if (TYPE_MODE (t1) != BLKmode)
  120.     return t1;
  121.   else if (TYPE_MODE (t2) != BLKmode)
  122.     return t2;
  123.  
  124.   /* Otherwise, return the type that has a constant size.  */
  125.   if (TREE_CONSTANT (TYPE_SIZE (t1)))
  126.     return t1;
  127.   else if (TREE_CONSTANT (TYPE_SIZE (t2)))
  128.     return t2;
  129.  
  130.   /* In this case, both types have variable size.  It's probably
  131.      best to leave the "type mismatch" because changing it could
  132.      case a bad self-referential reference.  */
  133.   return 0;
  134. }
  135.  
  136. /* Return an expression tree representing an equality comparison of
  137.    A1 and A2, two objects of ARRAY_TYPE.  The returned expression should
  138.    be of type RESULT_TYPE
  139.  
  140.    Two arrays are equal if the lengths in each dimension are equal
  141.    and the data is equal.  We perform the length tests in as efficient
  142.    a manner as possible.  */
  143.  
  144. static tree
  145. compare_arrays (result_type, a1, a2)
  146.      tree a1, a2;
  147.      tree result_type;
  148. {
  149.   tree t1 = TREE_TYPE (a1);
  150.   tree t2 = TREE_TYPE (a2);
  151.   tree result = convert (result_type, integer_one_node);
  152.   int length_zero_p = 0;
  153.  
  154.   /* Process each dimension separately and compare the lengths.  If any
  155.      dimension has a size known to be zero, set SIZE_ZERO_P to 1 to
  156.      suppress the comparison of the data.  */
  157.   while (TREE_CODE (t1) == ARRAY_TYPE)
  158.     {
  159.       tree lb1 = TYPE_MIN_VALUE (TYPE_DOMAIN (t1));
  160.       tree ub1 = TYPE_MAX_VALUE (TYPE_DOMAIN (t1));
  161.       tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2));
  162.       tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2));
  163.       tree bt = get_base_type (TREE_TYPE (lb1));
  164.       tree length1 = fold (build (MINUS_EXPR, bt, ub1, lb1));
  165.       tree length2 = fold (build (MINUS_EXPR, bt, ub2, lb2));
  166.       tree tem;
  167.       tree comparison;
  168.  
  169.       /* If the length of the first array is a constant, swap our operands
  170.      unless the length of the second array is the constant zero.  
  171.      Note that we have set the `length' values to the length - 1.  */
  172.       if (TREE_CODE (length1) == INTEGER_CST
  173.       && ! integer_zerop (fold (build (PLUS_EXPR, bt, length2,
  174.                        convert (bt, integer_one_node)))))
  175.     {
  176.       tem = a1, a1 = a2, a2 = tem;
  177.       tem = t1, t1 = t2, t2 = tem;
  178.       tem = lb1, lb1 = lb2, lb2 = tem;
  179.       tem = ub1, ub1 = ub2, ub2 = tem;
  180.       tem = length1, length1 = length2, length2 = tem;
  181.     }
  182.  
  183.       /* If the length of this dimension in the second array is the constant
  184.      zero, we can just go inside the original bounds for the first
  185.      array and see if last < first.  */
  186.       if (integer_zerop (fold (build (PLUS_EXPR, bt, length2,
  187.                       convert (bt, integer_one_node)))))
  188.     {
  189.       tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
  190.       tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
  191.  
  192.       comparison = build_binary_op (LT_EXPR, result_type, ub, lb);
  193.  
  194.       if (contains_placeholder_p (comparison))
  195.         comparison = build (WITH_RECORD_EXPR, result_type,
  196.                 comparison, a1);
  197.  
  198.       length_zero_p = 1;
  199.     }
  200.  
  201.       /* If the length is some other constant value, we know that the
  202.      this dimension in the first array cannot be superflat, so we
  203.      can just use its length from the actual stored bounds.  */
  204.       else if (TREE_CODE (length2) == INTEGER_CST)
  205.     {
  206.       ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
  207.       lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
  208.       ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
  209.       lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
  210.       bt = get_base_type (TREE_TYPE (ub1));
  211.  
  212.       comparison
  213.         = build_binary_op (EQ_EXPR, result_type, 
  214.                    build_binary_op (MINUS_EXPR, bt, ub1, lb1),
  215.                    build_binary_op (MINUS_EXPR, bt, ub2, lb2));
  216.  
  217.       /* Note that we know that UB2 and LB2 are constant and hence
  218.          cannot contain a PLACEHOLDER_EXPR.  */
  219.  
  220.       if (contains_placeholder_p (comparison))
  221.         comparison = build (WITH_RECORD_EXPR, result_type, comparison, a1);
  222.     }
  223.  
  224.       /* Otherwise compare the computed lengths.  */
  225.       else
  226.     {
  227.       if (contains_placeholder_p (length1))
  228.         length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
  229.       if (contains_placeholder_p (length2))
  230.         length2 = build (WITH_RECORD_EXPR, bt, length2, a2);
  231.  
  232.       comparison
  233.         = build_binary_op (EQ_EXPR, result_type, length1, length2);
  234.     }
  235.  
  236.       result = build_binary_op (TRUTH_ANDIF_EXPR, result_type,
  237.                 result, comparison);
  238.  
  239.       t1 = TREE_TYPE (t1);
  240.       t2 = TREE_TYPE (t2);
  241.     }
  242.  
  243.   /* Unless the size of some bound is known to be zero, compare the
  244.      data in the array.  */
  245.   if (! length_zero_p)
  246.     {
  247.       tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2));
  248.  
  249.       if (type != 0)
  250.     a1 = convert (type, a1), a2 = convert (type, a2);
  251.  
  252.  
  253.       result
  254.     = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
  255.                build (EQ_EXPR, result_type, a1, a2));
  256.     }
  257.  
  258.   return result;
  259. }
  260.  
  261. /* Compute the result of applying OP_CODE to LHS and RHS, where both are of
  262.    type TYPE.  We know that TYPE is a modular type with a nonbinary
  263.    modulus.  */
  264.  
  265. static tree
  266. nonbinary_modular_operation (op_code, type, lhs, rhs)
  267.      enum tree_code op_code;
  268.      tree type;
  269.      tree lhs, rhs;
  270. {
  271.   tree modulus = TYPE_MODULUS (type);
  272.   int needed_precision
  273.     = (TREE_INT_CST_HIGH (modulus) != 0
  274.        ? HOST_BITS_PER_WIDE_INT + floor_log2 (TREE_INT_CST_HIGH (modulus)) + 1
  275.        : TREE_INT_CST_LOW (modulus) == 0 ? 1
  276.        : floor_log2 (TREE_INT_CST_LOW (modulus)) + 1);
  277.   int precision;
  278.   int unsignedp = 1;
  279.   tree op_type = type;
  280.   tree result;
  281.  
  282.   /* If this is an addition of a constant, convert it to a subtraction
  283.      of a constant since we can do that faster.  */
  284.   if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
  285.     rhs = fold (build (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR;
  286.  
  287.   /* For the logical operations, we only need PRECISION bits.  For
  288.      addition and subraction, we need one more and for multiplication we
  289.      need twice as many.  But we never want to make a size smaller than
  290.      our size. */
  291.   if (op_code == PLUS_EXPR || op_code == MINUS_EXPR)
  292.     needed_precision += 1;
  293.   else if (op_code == MULT_EXPR)
  294.     needed_precision *= 2;
  295.  
  296.   precision = MAX (needed_precision, TYPE_PRECISION (op_type));
  297.  
  298.   /* Unsigned will do for everything but subtraction.  */
  299.   if (op_code == MINUS_EXPR)
  300.     unsignedp = 0;
  301.  
  302.   /* If our type is the wrong signedness or isn't wide enough, make a new
  303.      type and convert both our operands to it.  */
  304.   if (TYPE_PRECISION (op_type) < precision
  305.       || TREE_UNSIGNED (op_type) != unsignedp)
  306.     {
  307.       /* Copy the node so we ensure it can be modified to make it modular.  */
  308.       op_type = copy_node (type_for_size (precision, unsignedp));
  309.       modulus = convert (op_type, modulus);
  310.       TYPE_MODULUS (op_type) = modulus;
  311.       TYPE_MODULAR_P (op_type) = 1;
  312.       lhs = convert (op_type, lhs);
  313.       rhs = convert (op_type, rhs);
  314.     }
  315.  
  316.   /* Do the operation, then we'll fix it up.  */
  317.   result = fold (build (op_code, op_type, lhs, rhs));
  318.  
  319.   /* For multiplication, we have no choice but to do a full modulus
  320.      operation.  However, we want to do this in the narrowest
  321.      possible size.  */
  322.   if (op_code == MULT_EXPR)
  323.     {
  324.       tree div_type = copy_node (type_for_size (needed_precision, 1));
  325.       modulus = convert (div_type, modulus);
  326.       TYPE_MODULUS (div_type) = modulus;
  327.       TYPE_MODULAR_P (div_type) = 1;
  328.       result = convert (op_type,
  329.             fold (build (TRUNC_MOD_EXPR, div_type,
  330.                      convert (div_type, result), modulus)));
  331.     }
  332.  
  333.   /* For subtraction, add the modulus back if we are negative.  */
  334.   else if (op_code == MINUS_EXPR)
  335.     {
  336.       result = save_expr (result);
  337.       result = fold (build (COND_EXPR, op_type,
  338.                 build (LT_EXPR, integer_type_node, result,
  339.                    convert (op_type, integer_zero_node)),
  340.                 fold (build (PLUS_EXPR, op_type,
  341.                      result, modulus)),
  342.                 result));
  343.     }
  344.  
  345.   /* For the other operations, subtract the modulus if we are >= it.  */
  346.   else
  347.     {
  348.       result = save_expr (result);
  349.       result = fold (build (COND_EXPR, op_type,
  350.                 build (GE_EXPR, integer_type_node,
  351.                    result, modulus),
  352.                 fold (build (MINUS_EXPR, op_type,
  353.                      result, modulus)),
  354.                 result));
  355.     }
  356.  
  357.   return convert (type, result);
  358. }
  359.  
  360. /* Make a binary operation of kind OP_CODE.  RESULT_TYPE is the type
  361.    desired for the result.  Usually the operation is to be performed
  362.    in that type.  For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
  363.    in which case the type to be used will be derived from the operands.
  364.  
  365.    This function is very much unlike the ones for C and C++ since we
  366.    have already done any type conversion and matching required.  All we
  367.    have to do here is validate the work done by SEM and handle subtypes.  */
  368.  
  369. tree
  370. build_binary_op (op_code, result_type, left_operand, right_operand)
  371.      enum tree_code op_code;
  372.      tree result_type;
  373.      tree left_operand;
  374.      tree right_operand;
  375. {
  376.   tree left_type  = TREE_TYPE (left_operand);
  377.   tree right_type = TREE_TYPE (right_operand);
  378.   tree left_base_type = get_base_type (left_type);
  379.   tree right_base_type = get_base_type (right_type);
  380.   tree operation_type = (result_type != 0 && TYPE_EXTRA_SUBTYPE_P (result_type)
  381.              ? get_base_type (result_type) : result_type);
  382.   tree modulus = (operation_type != 0 && TYPE_MODULAR_P (operation_type)
  383.           ? TYPE_MODULUS (operation_type) : 0);
  384.   tree result;
  385.   int has_side_effects = 0;
  386.  
  387.   switch (op_code)
  388.     {
  389.     case MODIFY_EXPR:
  390.       if (operation_type == 0)
  391.     operation_type = left_type;
  392.  
  393.       /* If we are copying one array or record to another, find the best type
  394.      to use.  */
  395.       if ((TREE_CODE (left_type) == ARRAY_TYPE
  396.        && TREE_CODE (right_type) == ARRAY_TYPE)
  397.       || (TREE_CODE (left_type) == RECORD_TYPE
  398.           && TREE_CODE (right_type) == RECORD_TYPE))
  399.     {
  400.       tree best_type = find_common_type (left_type, right_type);
  401.  
  402.       if (best_type && left_type != best_type)
  403.         left_operand = convert (best_type, left_operand);
  404.       if (best_type && right_type != best_type)
  405.         right_operand = convert (best_type, right_operand);
  406.  
  407.       if (best_type)
  408.         operation_type = best_type;
  409.     }
  410.       else
  411.     right_operand = convert (operation_type, right_operand);
  412.  
  413.       has_side_effects = 1;
  414.       modulus = 0;
  415.       break;
  416.  
  417.     case ARRAY_REF:
  418.       if (operation_type == 0)
  419.     operation_type = TREE_TYPE (left_type);
  420.  
  421.       /* First convert the right operand to its base type.  This will
  422.      prevent unneed signedness conversions when sizetype is wider than
  423.      integer.  */
  424.       right_operand = convert (right_base_type, right_operand);
  425.       right_operand = convert (TYPE_DOMAIN (left_type), right_operand);
  426.  
  427.       if (! TREE_CONSTANT (right_operand)
  428.       || ! TREE_CONSTANT (TYPE_MIN_VALUE (right_type)))
  429.     mark_addressable (left_operand);
  430.  
  431.       modulus = 0;
  432.       break;
  433.  
  434.     case GE_EXPR:
  435.     case LE_EXPR:
  436.     case GT_EXPR:
  437.     case LT_EXPR:
  438.       if (TREE_CODE (left_type) == POINTER_TYPE)
  439.     gigi_abort (501);
  440.  
  441.       /* ... fall through ... */
  442.  
  443.     case EQ_EXPR:
  444.     case NE_EXPR:
  445.       /* If both objects are arrays, compare them specially.  */
  446.       if (TREE_CODE (left_type) == ARRAY_TYPE
  447.       && TREE_CODE (right_type) == ARRAY_TYPE)
  448.     {
  449.       result = compare_arrays (result_type, left_operand, right_operand);
  450.  
  451.       if (op_code == EQ_EXPR)
  452.         ;
  453.       else if (op_code == NE_EXPR)
  454.         result = invert_truthvalue (result);
  455.       else
  456.         gigi_abort (502);
  457.  
  458.       return result;
  459.     }
  460.  
  461.       /* Otherwise, the base types must be the same unless the objects are
  462.      records.  If we have records, use the best type and convert both
  463.      operands to that type.  */
  464.       if (left_base_type != right_base_type)
  465.     {
  466.       if (TREE_CODE (left_base_type) == RECORD_TYPE
  467.           && TREE_CODE (right_base_type) == RECORD_TYPE)
  468.         {
  469.           /* The only way these are permitted to be the same is if both
  470.          types have the same name.  In that case, one of them must
  471.          not be self-referential.  Use that one as the best type.
  472.          Even better is if one is of fixed size.  */
  473.           tree best_type = 0;
  474.  
  475.           if (TYPE_NAME (left_base_type) == 0
  476.           || TYPE_NAME (left_base_type) != TYPE_NAME (right_base_type))
  477.         gigi_abort (503);
  478.  
  479.           if (TREE_CONSTANT (TYPE_SIZE (left_base_type)))
  480.         best_type = left_base_type;
  481.           else if (TREE_CONSTANT (TYPE_SIZE (right_base_type)))
  482.         best_type = right_base_type;
  483.           else if (! contains_placeholder_p (TYPE_SIZE (left_base_type)))
  484.         best_type = left_base_type;
  485.           else if (! contains_placeholder_p (TYPE_SIZE (right_base_type)))
  486.         best_type = right_base_type;
  487.           else
  488.         gigi_abort (504);
  489.  
  490.           left_operand = convert (best_type, left_operand);
  491.           right_operand = convert (best_type, right_operand);
  492.         }
  493.       else
  494.         gigi_abort (505);
  495.     }
  496.  
  497.       /* If we are comparing a fat pointer against zero, we need to 
  498.      just compare the template pointer.  */
  499.       else if (TYPE_FAT_POINTER_P (left_base_type)
  500.            && TREE_CODE (right_operand) == CONSTRUCTOR
  501.            && integer_zerop (TREE_VALUE (TREE_OPERAND (right_operand, 1))))
  502.     {
  503.       right_operand
  504.         = build_component_ref (left_operand,
  505.                    NULL_TREE,
  506.                    TREE_CHAIN (TYPE_FIELDS (left_base_type)));
  507.       left_operand = convert (TREE_TYPE (right_operand),
  508.                   integer_zero_node);
  509.     }
  510.       else
  511.     {
  512.       left_operand = convert (left_base_type, left_operand);
  513.       right_operand = convert (right_base_type, right_operand);
  514.     }
  515.  
  516.       modulus = 0;
  517.       break;
  518.  
  519.     case PREINCREMENT_EXPR:
  520.     case PREDECREMENT_EXPR:
  521.     case POSTINCREMENT_EXPR:
  522.     case POSTDECREMENT_EXPR:
  523.       /* In these, the result type and the left operand type should be the
  524.      same.  Do the operation in the base type of those and convert the
  525.      right operand (which is an integer) to that type.
  526.  
  527.      Note that these operations are only used in loop control where
  528.      we guarantee that no overflow can occur.  So nothing special need
  529.      be done for modular types.  */
  530.  
  531.       if (left_type != result_type)
  532.     gigi_abort (506);
  533.  
  534.       operation_type = get_base_type (result_type);
  535.       left_operand = convert (operation_type, left_operand);
  536.       right_operand = convert (operation_type, right_operand);
  537.       has_side_effects = 1;
  538.       modulus = 0;
  539.       break;
  540.  
  541.     case LSHIFT_EXPR:
  542.     case RSHIFT_EXPR:
  543.     case LROTATE_EXPR:
  544.     case RROTATE_EXPR:
  545.       /* The RHS of a shift can be any type.  In addition, we don't support
  546.      them on modular types.  Otherwise, processing is the same as
  547.      normal.  */
  548.       if (operation_type != left_base_type || modulus != 0)
  549.     gigi_abort (514);
  550.  
  551.       left_operand = convert (operation_type, left_operand);
  552.       break;
  553.  
  554.     case TRUTH_ANDIF_EXPR:
  555.     case TRUTH_ORIF_EXPR:
  556.     case TRUTH_AND_EXPR:
  557.     case TRUTH_OR_EXPR:
  558.     case TRUTH_XOR_EXPR:
  559.       left_operand = truthvalue_conversion (left_operand);
  560.       right_operand = truthvalue_conversion (right_operand);
  561.       goto common;
  562.  
  563.     case BIT_AND_EXPR:
  564.     case BIT_IOR_EXPR:
  565.     case BIT_XOR_EXPR:
  566.       /* For binary modulus, if the inputs are in range, so are the
  567.      outputs.  */
  568.       if (modulus != 0 && integer_pow2p (modulus))
  569.     modulus = 0;
  570.  
  571.       goto common;
  572.  
  573.     case TRUNC_DIV_EXPR:   case TRUNC_MOD_EXPR:
  574.     case CEIL_DIV_EXPR:    case CEIL_MOD_EXPR:
  575.     case FLOOR_DIV_EXPR:   case FLOOR_MOD_EXPR:
  576.     case ROUND_DIV_EXPR:   case ROUND_MOD_EXPR:
  577.       /* These always produce results lower than either operand.  */
  578.       modulus = 0;
  579.       goto common;
  580.  
  581.     default:
  582.     common:
  583.       /* The result type should be the same as the base types of the
  584.      both operands (and they should be the same).  Convert
  585.      everything to the result type.  */
  586.  
  587.       if (operation_type != left_base_type
  588.       || left_base_type != right_base_type)
  589.     gigi_abort (507);
  590.  
  591.       left_operand = convert (operation_type, left_operand);
  592.       right_operand = convert (operation_type, right_operand);
  593.     }
  594.  
  595.   if (modulus != 0 && ! integer_pow2p (modulus))
  596.     {
  597.       result = nonbinary_modular_operation (op_code, operation_type,
  598.                         left_operand, right_operand);
  599.       modulus = 0;
  600.     }
  601.   else
  602.     result = fold (build (op_code, operation_type,
  603.               left_operand, right_operand));
  604.  
  605.   TREE_SIDE_EFFECTS (result) |= has_side_effects;
  606.   TREE_CONSTANT (result)
  607.     = (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
  608.        && op_code != ARRAY_REF);
  609.  
  610.   /* If we are working with modular types, perform the MOD operation
  611.      if something above hasn't eliminated the need for it.  */
  612.   if (modulus != 0)
  613.     result = fold (build (FLOOR_MOD_EXPR, operation_type, result,
  614.               convert (operation_type, modulus)));
  615.  
  616.   if (result_type != 0 && result_type != operation_type)
  617.     result = convert (result_type, result);
  618.  
  619.   return result;
  620. }
  621.  
  622. /* Similar, but for unary operations.  */
  623.  
  624. tree
  625. build_unary_op (op_code, result_type, operand)
  626.      enum tree_code op_code;
  627.      tree result_type;
  628.      tree operand;
  629. {
  630.   tree type = TREE_TYPE (operand);
  631.   tree base_type = get_base_type (type);
  632.   tree operation_type = (result_type != 0 && TYPE_EXTRA_SUBTYPE_P (result_type)
  633.              ? get_base_type (result_type) : result_type);
  634.   tree result;
  635.   int side_effects = 0;
  636.  
  637.   switch (op_code)
  638.     {
  639.     case TRUTH_NOT_EXPR:
  640.       if (result_type != base_type)
  641.     gigi_abort (508);
  642.  
  643.       result = invert_truthvalue (truthvalue_conversion (operand));
  644.       break;
  645.  
  646.     case ADDR_EXPR:
  647.       if (TREE_CODE (operand) == INDIRECT_REF
  648.       || TREE_CODE (operand) == UNCONSTRAINED_ARRAY_REF)
  649.     result = TREE_OPERAND (operand, 0);
  650.       else if (TREE_CODE (operand) == TRANSFORM_EXPR)
  651.     {
  652.       TREE_TRANSFORM_ADDR (operand) = 1;
  653.       result = operand;
  654.  
  655.       if (type != error_mark_node)
  656.         {
  657.           if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
  658.         type = TREE_TYPE (type);
  659.           else
  660.         type = build_pointer_type (type);
  661.  
  662.           TREE_TYPE (result) = type;
  663.         }
  664.     }
  665.       else
  666.     {
  667.       if (type != error_mark_node)
  668.         operation_type = build_pointer_type (type);
  669.  
  670.       mark_addressable (operand);
  671.       result = fold (build1 (op_code, operation_type, operand));
  672.     }
  673.  
  674.       TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
  675.       break;
  676.  
  677.     case INDIRECT_REF:
  678.       /* If we want to refer to an entire unconstrained array,
  679.      make up an expression to do so.  This will never survive to
  680.      the backend.  */
  681.       if (TYPE_FAT_POINTER_P (type))
  682.     result = build1 (UNCONSTRAINED_ARRAY_REF,
  683.              TYPE_UNCONSTRAINED_ARRAY (type), operand);
  684.       else
  685.     {
  686.       result = fold (build1 (op_code, TREE_TYPE (type), operand));
  687.       TREE_READONLY (result) = TREE_STATIC (result)
  688.         = TREE_READONLY (TREE_TYPE (type));
  689.     }
  690.  
  691.       side_effects = flag_volatile 
  692.     || (! TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
  693.       break;
  694.  
  695.     case NEGATE_EXPR:
  696.     case BIT_NOT_EXPR:
  697.       {
  698.     tree modulus = (operation_type && TYPE_MODULAR_P (operation_type)
  699.             ? TYPE_MODULUS (operation_type) : 0);
  700.     int mod_pow2 = modulus != 0 && integer_pow2p (modulus);
  701.  
  702.     /* If this is a modular type, there are various possibilities
  703.        depending on the operation and whether the modulus is a
  704.        power of two or not.  */
  705.  
  706.     if (modulus != 0)
  707.       {
  708.         if (operation_type != base_type)
  709.           gigi_abort (509);
  710.  
  711.         operand = convert (operation_type, operand);
  712.  
  713.         /* The fastest in the negate case for binary modulus is
  714.            the straightforward code; the TRUNC_MOD_EXPR below
  715.            is an AND operation.  */
  716.         if (op_code == NEGATE_EXPR && mod_pow2)
  717.           result = fold (build (TRUNC_MOD_EXPR, operation_type,
  718.                     fold (build1 (NEGATE_EXPR, operation_type,
  719.                           operand)),
  720.                     modulus));
  721.  
  722.         /* For nonbinary negate case, return zero for zero operand,
  723.            else return the modulus minus the operand.  If the modulus
  724.            is a power of two minus one, we can do the subtraction
  725.            as an XOR since it is equivalent and faster on most machines. */
  726.         else if (op_code == NEGATE_EXPR && ! mod_pow2)
  727.           {
  728.         if (integer_pow2p (fold (build (PLUS_EXPR, operation_type,
  729.                         modulus,
  730.                         convert (operation_type,
  731.                              integer_one_node)))))
  732.           result = fold (build (BIT_XOR_EXPR, operation_type,
  733.                     operand, modulus));
  734.         else
  735.           result = fold (build (MINUS_EXPR, operation_type,
  736.                     modulus, operand));
  737.  
  738.         result = fold (build (COND_EXPR, operation_type,
  739.                       fold (build (NE_EXPR, integer_type_node,
  740.                            operand,
  741.                            convert (operation_type,
  742.                                 integer_zero_node))),
  743.                       result, operand));
  744.           }
  745.         else
  746.           {
  747.         /* For the NOT cases, we need a constant equal to
  748.            the modulus minus one.  For a binary modulus, we
  749.            XOR against the constant and subtract the operand from
  750.            that constant for nonbinary modulus.  */
  751.  
  752.         tree cnst = fold (build (MINUS_EXPR, operation_type, modulus,
  753.                      convert (operation_type,
  754.                           integer_one_node)));
  755.  
  756.         if (mod_pow2)
  757.           result = fold (build (BIT_XOR_EXPR, operation_type,
  758.                     operand, cnst));
  759.         else
  760.           result = fold (build (MINUS_EXPR, operation_type,
  761.                     cnst, operand));
  762.           }
  763.  
  764.         break;
  765.       }
  766.       }
  767.  
  768.       /* ... fall through ... */
  769.  
  770.     default:
  771.       if (operation_type != base_type)
  772.     gigi_abort (509);
  773.  
  774.       result = fold (build1 (op_code, operation_type, convert (operation_type,
  775.                                    operand)));
  776.     }
  777.  
  778.   if (side_effects)
  779.     {
  780.       TREE_SIDE_EFFECTS (result) = 1;
  781.       if (TREE_CODE (result) == INDIRECT_REF)
  782.     TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
  783.     }
  784.  
  785.   if (result_type != 0 && TREE_TYPE (result) != result_type)
  786.     result = convert (result_type, result);
  787.  
  788.   return result;
  789. }
  790.  
  791. /* Similar, but for COND_EXPR.  */
  792.  
  793. tree
  794. build_cond_expr (result_type, condition_operand, true_operand, false_operand)
  795.      tree result_type;
  796.      tree condition_operand;
  797.      tree true_operand;
  798.      tree false_operand;
  799. {
  800.   /* Front-end verifies that result, true and false operands have same base
  801.      type. Convert everything to the result type.  */
  802.  
  803.   true_operand  = convert (result_type, true_operand);
  804.   false_operand = convert (result_type, false_operand);
  805.  
  806.   return fold (build (COND_EXPR, result_type, condition_operand,
  807.               true_operand, false_operand));
  808. }
  809.  
  810.  
  811. /* Build a CALL_EXPR to call FUNDECL with one argument, ARG.  Return
  812.    the CALL_EXPR.  */
  813. tree
  814. build_call_1_expr (fundecl, arg)
  815.      tree fundecl;
  816.      tree arg;
  817. {
  818.   tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
  819.              build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
  820.              chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)),
  821.              NULL_TREE);
  822.  
  823.   TREE_SIDE_EFFECTS (call) = 1;
  824.  
  825.   return call;
  826. }
  827.  
  828. /* Likewise to call FUNDECL with no arguments.  */
  829.  
  830. tree
  831. build_call_0_expr (fundecl)
  832.      tree fundecl;
  833. {
  834.   tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
  835.              build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
  836.              NULL_TREE, NULL_TREE);
  837.  
  838.   TREE_SIDE_EFFECTS (call) = 1;
  839.  
  840.   return call;
  841. }
  842.  
  843.  
  844. /* Return a CONSTRUCTOR of TYPE whose list is LIST.  */
  845.  
  846. tree
  847. build_constructor (type, list)
  848.      tree type;
  849.      tree list;
  850. {
  851.   tree elmt;
  852.   int allconstant = 1;
  853.   int side_effects = 0;
  854.   tree result;
  855.  
  856.   for (elmt = list; elmt; elmt = TREE_CHAIN (elmt))
  857.     {
  858.       if (! TREE_CONSTANT (TREE_VALUE (elmt)))
  859.     allconstant = 0;
  860.  
  861.       if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt)))
  862.     side_effects = 1;
  863.     }
  864.  
  865.   result = build (CONSTRUCTOR, type, NULL_TREE, list);
  866.   TREE_CONSTANT (result) = allconstant;
  867.   TREE_STATIC (result) = allconstant;
  868.   TREE_SIDE_EFFECTS (result) = side_effects;
  869.  
  870.   return result;
  871. }
  872.  
  873. /* Return a COMPONENT_REF to access a field that is given by COMPONENT,
  874.    an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
  875.    for the field, or both.
  876.  
  877.    We also handle the fact that we might have been passed a pointer to the
  878.    actual record and know how to look for fields in variant parts.  */
  879.  
  880. tree
  881. build_simple_component_ref (record_variable, component, field)
  882.      tree record_variable;
  883.      tree component;
  884.      tree field;
  885. {
  886.   tree record_type = TREE_TYPE (record_variable);
  887.   tree ref;
  888.  
  889.   /* Handle added pointer for pass-by-reference values.  */
  890.   if (TREE_CODE (record_type) == POINTER_TYPE)
  891.     {
  892.       record_variable
  893.     = build_unary_op (INDIRECT_REF, NULL_TREE, record_variable);
  894.       record_type = TREE_TYPE (record_variable);
  895.     }
  896.  
  897.   if ((TREE_CODE (record_type) != RECORD_TYPE
  898.        && TREE_CODE (record_type) != UNION_TYPE
  899.        && TREE_CODE (record_type) != QUAL_UNION_TYPE)
  900.       || TYPE_SIZE (record_type) == 0)
  901.     gigi_abort (510);
  902.  
  903.   if (field == 0 || DECL_CONTEXT (field) != record_type)
  904.     /* Check if there is a field with name COMPONENT in the record.  */
  905.     {
  906.       if (component == 0)
  907.     gigi_abort (511);
  908.  
  909.       /* ??? Explore later if we can use the TYPE_LANG_SPECIFIC optimization
  910.      that appears in C version of this function.  */
  911.  
  912.       for (field = TYPE_FIELDS (record_type); field;
  913.        field = TREE_CHAIN (field))
  914.     {
  915.       if (DECL_NAME (field) == component)
  916.         break;
  917.       else if (DECL_FOR_VARIANT_P (field))
  918.          {
  919.           tree field_ref
  920.         = build_simple_component_ref (record_variable, 
  921.                           NULL_TREE, field);
  922.           ref = build_simple_component_ref (field_ref, 
  923.                         component, NULL_TREE);
  924.  
  925.           if (ref != 0)
  926.         return ref;
  927.         }
  928.     }
  929.     }
  930.  
  931.   if (!field)
  932.     return 0;
  933.  
  934.   ref = build (COMPONENT_REF, TREE_TYPE (field), record_variable, field);
  935.  
  936.   if (TREE_READONLY (record_variable) || TREE_READONLY (field))
  937.     TREE_READONLY (ref) = 1;
  938.   if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field))
  939.     TREE_THIS_VOLATILE (ref) = 1;
  940.  
  941.   return ref;
  942. }
  943.  
  944. /* Like build_simple_component_ref, except that we look in the field __parent
  945.    if the field is not defined at this level */
  946.  
  947. tree
  948. build_component_ref (record_variable, component, field)
  949.      tree record_variable;
  950.      tree component;
  951.      tree field;
  952. {
  953.   tree local_field;
  954.   tree parent_ref;
  955.   static tree parent_comp = 0;
  956.   tree comp_ref;
  957.  
  958.   if (!parent_comp) 
  959.     parent_comp = get_identifier (Get_Name_String (Name_uParent)); 
  960.  
  961.   /* See if the field is present at this level.  */
  962.   comp_ref = build_simple_component_ref (record_variable, component, field);
  963.   if (comp_ref)
  964.     return comp_ref;
  965.  
  966.   /* If it is not present, look recursively in the parent.  */
  967.  
  968.   parent_ref = build_simple_component_ref (record_variable, 
  969.                        parent_comp, NULL_TREE);
  970.   if (parent_ref)
  971.     return build_component_ref (parent_ref, component, field);
  972.  
  973.   /* If FIELD was specified, assume this is an invalid user field so
  974.      raise constraint error.  Otherwise, we can't find the type to return, so
  975.      abort.  */
  976.   else if (field != 0)
  977.     return build1 (NULL_EXPR, TREE_TYPE (field),
  978.            build_call_0_expr (raise_constraint_error_decl));
  979.   else
  980.     gigi_abort (512);
  981. }
  982.  
  983. /* Build a GCC tree to call an allocation or deallocation function.
  984.    If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
  985.    generate an allocator.
  986.  
  987.    GNU_SIZE is the size of the object and ALIGN is the alignment.
  988.    GNAT_PROC, if present is a procedure to call and GNAT_POOL is the
  989.    storage pool to use.  If not preset, malloc and free will be used.  */
  990.  
  991. tree
  992. build_call_alloc_dealloc (gnu_obj, gnu_size, align, gnat_proc, gnat_pool)
  993.      tree gnu_obj;
  994.      tree gnu_size;
  995.      int align;
  996.      Entity_Id gnat_proc;
  997.      Entity_Id gnat_pool;
  998. {
  999.   tree gnu_align = size_int (align / BITS_PER_UNIT);
  1000.  
  1001.   gnu_size = size_binop (CEIL_DIV_EXPR, gnu_size, size_int (BITS_PER_UNIT));
  1002.  
  1003.   if (Present (gnat_proc))
  1004.     {
  1005.       /* The size is the third parameter; the alignment is the same type.  */
  1006.       Entity_Id gnat_size_type
  1007.     = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
  1008.       tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
  1009.       tree gnu_proc = gnat_to_gnu_entity (gnat_proc, NULL_TREE, 0);
  1010.       tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
  1011.       tree gnu_pool = gnat_to_gnu_entity (gnat_pool, NULL_TREE, 0);
  1012.       tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
  1013.       tree gnu_args = NULL_TREE;
  1014.       tree gnu_call;
  1015.  
  1016.       /* The first arg is always the address of the storage pool; next
  1017.      comes the address of the object, for a deallocator, then the
  1018.      size and alignment.  */
  1019.  
  1020.       gnu_args
  1021.     = chainon (gnu_args, build_tree_list (NULL_TREE, gnu_pool_addr));
  1022.  
  1023.       if (gnu_obj)
  1024.     gnu_args = chainon (gnu_args, build_tree_list (NULL_TREE, gnu_obj));
  1025.  
  1026.       gnu_args = chainon (gnu_args,
  1027.               build_tree_list (NULL_TREE,
  1028.                        convert (gnu_size_type, gnu_size)));
  1029.       gnu_args = chainon (gnu_args,
  1030.               build_tree_list (NULL_TREE, convert (gnu_size_type,
  1031.                                    gnu_align)));
  1032.  
  1033.       gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
  1034.             gnu_proc_addr, gnu_args, NULL_TREE);
  1035.       TREE_SIDE_EFFECTS (gnu_call) = 1;
  1036.       return gnu_call;
  1037.     }
  1038.   else if (gnu_obj)
  1039.     return build_call_1_expr (free_decl, gnu_obj);
  1040.   else
  1041.     return build_call_1_expr (malloc_decl, gnu_size);
  1042. }
  1043.  
  1044. /* Build a GCC tree to correspond to allocating an object of TYPE whose
  1045.    initial value is INIT, if INIT is nonzero.  Convert the expression to
  1046.    RESULT_TYPE, which must be some type of pointer.  Return the tree.
  1047.    GNAT_PROC and GNAT_POOL optionally give the procedure to call and
  1048.    the storage pool to use.  */
  1049.  
  1050. tree
  1051. build_allocator (type, init, result_type, gnat_proc, gnat_pool)
  1052.      tree type;
  1053.      tree init;
  1054.      tree result_type;
  1055.      Entity_Id gnat_proc;
  1056.      Entity_Id gnat_pool;
  1057. {
  1058.   /* Counts number of allocators we were able to do by statically allocating
  1059.      memory when at top level.  */
  1060.   static int alloc_var_index = 0;
  1061.   tree size = TYPE_SIZE (type);
  1062.   tree ptr_type;
  1063.   tree result;
  1064.  
  1065.   /* If RESULT_TYPE is a fat pointer, set SIZE to be the sum of the sizes
  1066.      of the object and its template.  Allocate the whole thing and fill in
  1067.      the parts that are known.  */
  1068.   if (TYPE_FAT_POINTER_P (result_type))
  1069.     {
  1070.       tree array_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (result_type)));
  1071.       tree template_type
  1072.     = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (result_type))));
  1073.       tree template_size
  1074.     = round_up (TYPE_SIZE (template_type),
  1075.             MAX (TYPE_ALIGN (array_type), TYPE_ALIGN (type)));
  1076.       tree storage;
  1077.       tree new_template_ptr, new_array_ptr;
  1078.  
  1079.       if (TREE_CODE (size) != INTEGER_CST
  1080.       && contains_placeholder_p (size))
  1081.     size = build (WITH_RECORD_EXPR, sizetype, size, init);
  1082.  
  1083.       size = size_binop (PLUS_EXPR, size, template_size);
  1084.  
  1085.       storage = build_call_alloc_dealloc (NULL_TREE, size,
  1086.                       MAX (TYPE_ALIGN (array_type),
  1087.                            TYPE_ALIGN (template_type)),
  1088.                       gnat_proc, gnat_pool);
  1089.       storage = save_expr (storage);
  1090.  
  1091.       /* The template is at the start of the allocated storage followed
  1092.      by the array itself.  */
  1093.       new_template_ptr = convert (build_pointer_type (template_type), storage);
  1094.  
  1095.       new_array_ptr
  1096.     = convert (build_pointer_type (array_type),
  1097.            build (PLUS_EXPR, TREE_TYPE (storage), storage,
  1098.               convert (TREE_TYPE (storage),
  1099.                    size_binop (EXACT_DIV_EXPR, template_size,
  1100.                            size_int (BITS_PER_UNIT)))));
  1101.  
  1102.       /* Copy the template and array (if initializer).  */
  1103.       new_template_ptr
  1104.     = build (COMPOUND_EXPR, build_pointer_type (template_type),
  1105.          build_binary_op (MODIFY_EXPR, template_type,
  1106.                   build_unary_op (INDIRECT_REF, NULL_TREE,
  1107.                           new_template_ptr),
  1108.                   build_template (template_type, type, init)),
  1109.          new_template_ptr);
  1110.  
  1111.       if (init != 0)
  1112.     new_array_ptr
  1113.       = build (COMPOUND_EXPR, build_pointer_type (array_type),
  1114.            build_binary_op (MODIFY_EXPR, array_type,
  1115.                     build_unary_op (INDIRECT_REF, NULL_TREE,
  1116.                             new_array_ptr),
  1117.                     build_unary_op (INDIRECT_REF, NULL_TREE,
  1118.                             build_unary_op (ADDR_EXPR,
  1119.                                     NULL_TREE,
  1120.                                     init))),
  1121.            new_array_ptr);
  1122.  
  1123.       return
  1124.     build_constructor
  1125.       (result_type,
  1126.        tree_cons (TYPE_FIELDS (result_type), new_array_ptr,
  1127.               tree_cons (TREE_CHAIN (TYPE_FIELDS (result_type)),
  1128.                  new_template_ptr, NULL_TREE)));
  1129.     }
  1130.  
  1131.   /* If we have an initializing expression, see if its size is simpler
  1132.      than the size from the type.  */
  1133.   if (init != 0 && TYPE_SIZE (TREE_TYPE (init)) != 0
  1134.       && (TREE_CODE (TYPE_SIZE (TREE_TYPE (init))) == INTEGER_CST
  1135.       || (TREE_CODE (size) != INTEGER_CST
  1136.           && contains_placeholder_p (size))))
  1137.     size = TYPE_SIZE (TREE_TYPE (init));
  1138.  
  1139.   /* If the size is still self-referential, reference the initializing
  1140.      expression, if it is present.  If not, this must have been a
  1141.      call to allocate a library-level object, in which case we use
  1142.      the maximum size.  */
  1143.   if (TREE_CODE (size) != INTEGER_CST && contains_placeholder_p (size))
  1144.     {
  1145.       if (init == 0)
  1146.     size = max_size (size, 1);
  1147.       else
  1148.     size = build (WITH_RECORD_EXPR, sizetype, size, init);
  1149.     }
  1150.  
  1151.   /* If we are at top-level and SIZE is a constant, we can actually
  1152.      allocate an object of TYPE and point to it.
  1153.      ??? At some point, we should make an attempt to do this above.  */
  1154.   if (global_bindings_p () && TREE_CODE (size) == INTEGER_CST)
  1155.     {
  1156.       char name[20];
  1157.  
  1158.       sprintf (name, "__V%d", alloc_var_index++);
  1159.       result
  1160.     = create_var_decl (name, NULL_PTR, type, init, size, 0, 0, 0, 0, 1);
  1161.       result = build_unary_op (ADDR_EXPR, NULL_TREE, result);
  1162.       init = 0;
  1163.     }
  1164.   else
  1165.     result = convert (result_type,
  1166.               build_call_alloc_dealloc (NULL_TREE, size,
  1167.                         TYPE_ALIGN (type),
  1168.                         gnat_proc, gnat_pool));
  1169.  
  1170.   /* If we have an initial value, put the new address into a SAVE_EXPR, assign
  1171.      the value, and return the address.  Do this with a COMPOUND_EXPR.  */
  1172.  
  1173.   if (init)
  1174.     {
  1175.       result = save_expr (result);
  1176.       result = build (COMPOUND_EXPR, TREE_TYPE (result),
  1177.               build_binary_op (MODIFY_EXPR, type,
  1178.                        build_unary_op (INDIRECT_REF, type,
  1179.                                result),
  1180.                        init),
  1181.               result);
  1182.     }
  1183.  
  1184.   return convert (result_type, result);
  1185. }
  1186.  
  1187. /* Indicate that we need to make the address of EXPR_NODE and it therefore
  1188.    should not be allocated in a register. Return 1 if successful.  */
  1189.  
  1190. int
  1191. mark_addressable (expr_node)
  1192.      tree expr_node;
  1193. {
  1194.   while (1)
  1195.     switch (TREE_CODE (expr_node))
  1196.       {
  1197.       case ADDR_EXPR:
  1198.       case COMPONENT_REF:
  1199.       case ARRAY_REF:
  1200.       case REALPART_EXPR:
  1201.       case IMAGPART_EXPR:
  1202.     expr_node = TREE_OPERAND (expr_node, 0);
  1203.     break;
  1204.  
  1205.       case CONSTRUCTOR:
  1206.     TREE_ADDRESSABLE (expr_node) = 1;
  1207.     return 1;
  1208.  
  1209.       case VAR_DECL:
  1210.       case PARM_DECL:
  1211.       case RESULT_DECL:
  1212.     put_var_into_stack (expr_node);
  1213.     TREE_ADDRESSABLE (expr_node) = 1;
  1214.     return 1;
  1215.  
  1216.       case FUNCTION_DECL:
  1217.     TREE_ADDRESSABLE (expr_node) = 1;
  1218.     return 1;
  1219.  
  1220.       default:
  1221.     return 1;
  1222.     }
  1223. }
  1224.