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-trans.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  131KB  |  3,915 lines
  1. /****************************************************************************/
  2. /*                                                                          */
  3. /*                         GNAT COMPILER COMPONENTS                         */
  4. /*                                                                          */
  5. /*                              A - T R A N S                               */
  6. /*                                                                          */
  7. /*                          C Implementation File                           */
  8. /*                                                                          */
  9. /*                            $Revision: 1.314 $                            */
  10. /*                                                                          */
  11. /*        Copyright (c) 1992,1993,1994,1995 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-urealp.h"
  40. #include "a-trans.h"
  41. #include "a-trans3.h"
  42. #include "a-gtran3.h"
  43. #include "a-trans4.h"
  44. #include "a-misc.h"
  45. #include "a-rtree.h"
  46.  
  47. int max_gnat_nodes;
  48. int number_names;
  49. struct Node *Nodes_Ptr;
  50. struct Elist_Header *Elists_Ptr;
  51. struct Elmt_Item *Elmts_Ptr;
  52. struct Name_Entry *Names_Ptr;
  53. struct String_Entry * Strings_Ptr;
  54. Char_Code * String_Chars_Ptr;
  55. struct List_Header *List_Headers_Ptr;
  56. char * Name_Chars_Ptr;
  57. Int Number_Units;
  58. struct Needed_File_Info *File_Info_Ptr;
  59.  
  60. /* First_Actual and Next_Actual functions from Sem_Util */
  61. #define First_Actual sem_util__first_actual
  62. Node_Id First_Actual (Node_Id Node);
  63. #define Next_Actual sem_util__next_actual
  64. Node_Id Next_Actual (Node_Id Actual_Id);
  65. #define Range sinfo__discrete_range
  66.  
  67. /* Offset from first sloc in file.  Set in parallel with LINENO
  68.    and CURRENT_FILE_NAME.  */
  69. int sloc_offset;
  70.  
  71. /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
  72.  
  73. static enum tree_code gnu_codes[Number_Node_Kinds];
  74.  
  75. /* Head of GNAT tree.  */
  76. extern Node_Id gnat_root;
  77.  
  78. /* Current node being treated, in case gigi_abort called */
  79. static Node_Id error_gnat_node;
  80.  
  81. /* Variable that stores the address of the raised exception.  
  82.    Nonzero means we are in an exception handler.  */
  83. static tree gnu_except_ptr_decl;
  84.  
  85. static tree tree_transform        PROTO((Node_Id));
  86. static void process_inlined_subprograms    PROTO((Node_Id));
  87. static void process_decls        PROTO((List_Id, List_Id, Node_Id));
  88. static tree emit_access_check        PROTO((tree));
  89. static tree emit_discriminant_check    PROTO((tree, Node_Id));
  90. static tree emit_range_check        PROTO((tree, Node_Id));
  91. static tree emit_index_check        PROTO((tree, tree, tree, tree));
  92. static tree emit_check            PROTO((tree, tree));
  93. static tree unchecked_convert        PROTO((tree, tree));
  94. static tree assoc_to_constructor    PROTO((Node_Id, tree, tree));
  95. static tree pos_to_constructor        PROTO((Node_Id, tree, Entity_Id));
  96. static tree maybe_implicit_deref    PROTO((tree));
  97. static tree maybe_unconstrained_array    PROTO((tree));
  98. static tree gnat_stabilize_reference    PROTO((tree));
  99. static int build_package_elab        PROTO((Entity_Id, int, tree, Node_Id));
  100. static int build_subprogram_elab    PROTO((Entity_Id, int));
  101. static void process_type        PROTO((Entity_Id));
  102. static tree elaborate_node_types    PROTO((Node_Id));
  103.  
  104. /* This is the main program of the back-end.  It sets up all the table
  105.    structures and then generates code.  */
  106.  
  107. void
  108. gigi (gnat_root, max_gnat_node, number_name, nodes_ptr, elists_ptr, elmts_ptr,
  109.       names_ptr, strings_ptr, string_chars_ptr, list_headers_ptr,
  110.       name_chars_ptr, number_units, file_info_ptr)
  111.      Node_Id gnat_root;
  112.      int max_gnat_node;
  113.      int number_name;
  114.      struct Node *nodes_ptr;
  115.      struct Elist_Header *elists_ptr;
  116.      struct Elmt_Item *elmts_ptr;
  117.      struct Name_Entry *names_ptr;
  118.      struct String_Entry *strings_ptr;
  119.      Char_Code *string_chars_ptr;
  120.      struct List_Header *list_headers_ptr;
  121.      char *name_chars_ptr;
  122.      Int number_units;
  123.      struct Needed_File_Info *file_info_ptr;
  124. {
  125.   max_gnat_nodes = max_gnat_node;
  126.   number_names =   number_name;
  127.   Nodes_Ptr = nodes_ptr - First_Node_Id;
  128.   Elists_Ptr = elists_ptr - First_Elist_Id;
  129.   Elmts_Ptr = elmts_ptr - First_Elmt_Id;
  130.   Names_Ptr = names_ptr - First_Name_Id;
  131.   Strings_Ptr = strings_ptr - First_String_Id;
  132.   String_Chars_Ptr = string_chars_ptr;
  133.   List_Headers_Ptr = list_headers_ptr - First_List_Id;
  134.   Name_Chars_Ptr = name_chars_ptr;
  135.   Number_Units = number_units;
  136.   File_Info_Ptr = file_info_ptr;
  137.  
  138.   if (Nkind (gnat_root) != N_Compilation_Unit)
  139.     gigi_abort (301);
  140.  
  141.   set_lineno (gnat_root, 0);
  142.  
  143.   /* Initialize ourselves.  */
  144.   init_gnat_to_gnu ();
  145.   init_code_table ();
  146.  
  147.   gnat_to_code (gnat_root);
  148. }
  149.  
  150.  
  151. /* This function is the driver of the GNAT to GCC tree transformation process.
  152.    GNAT_NODE is the root of some gnat tree.  It generates code for that
  153.    part of the tree.  */
  154.  
  155. void
  156. gnat_to_code (gnat_node)
  157.      Node_Id gnat_node;
  158. {
  159.   tree gnu_root;
  160.  
  161.   /* Save node number in case error */
  162.   error_gnat_node = gnat_node;
  163.  
  164.   gnu_root = tree_transform (gnat_node);
  165.  
  166.   /* This should just generate code, not return a value.  If it returns
  167.      a value, something is wrong.  */
  168.   if (gnu_root != error_mark_node)
  169.     gigi_abort (302);
  170. }
  171.  
  172. /* GNAT_NODE is the root of some GNAT tree.  Return the root of the
  173.    GCC tree corresponding to that GNAT tree.  Normally, no code is generated;
  174.    we just return an equivalent tree which is used elsewhere to generate
  175.    code.  */
  176.  
  177. tree
  178. gnat_to_gnu (gnat_node)
  179.      Node_Id gnat_node;
  180. {
  181.   tree gnu_root;
  182.  
  183.   /* Save node number in case error */
  184.   error_gnat_node = gnat_node;
  185.  
  186.   gnu_root = tree_transform (gnat_node);
  187.  
  188.   /* If we got no code as a result, something is wrong.  */
  189.   if (gnu_root == error_mark_node)
  190.     gigi_abort (303);
  191.  
  192.   return gnu_root;
  193. }
  194.  
  195. /* This function is the driver of the GNAT to GCC tree transformation process.
  196.    It is the entry point of the tree transformer.  GNAT_NODE is the root of
  197.    some GNAT tree.  Return the root of the corresponding GCC tree or
  198.    error_mark_node to signal that there is no GCC tree to return.
  199.  
  200.    The latter is the case if only code generation actions have to be performed
  201.    like in the case of if statements, loops, etc.  This routine is wrapped
  202.    in the above two routines for most purposes.  */
  203.  
  204. static tree
  205. tree_transform (gnat_node)
  206.      Node_Id gnat_node;
  207. {
  208.   tree gnu_result = error_mark_node; /* Default to no value. */
  209.   tree gnu_result_type = void_type_node;
  210.   tree gnu_expr;
  211.   enum tree_code gnu_code;
  212.   Node_Id gnat_temp;
  213.  
  214.   /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
  215.   set_lineno (gnat_node, 0);
  216.  
  217.   /* If this is a Statement and we are at top level, we add the statement
  218.      as an elaboration for a null tree.  That will cause it to be placed
  219.      in the elaboration procedure.  */
  220.   if (global_bindings_p ()
  221.       && (IN (Nkind (gnat_node), N_Statement)
  222.       || Nkind (gnat_node) == N_Procedure_Call_Statement))
  223.     {
  224.       add_pending_elaborations (NULL_TREE,
  225.                 make_transform_expr (gnat_node,
  226.                              error_mark_node));
  227.       return error_mark_node;
  228.     }
  229.  
  230.  switch (Nkind (gnat_node))
  231.     {
  232.       /********************************/
  233.       /* Chapter 2: Lexical Elements: */
  234.       /********************************/
  235.  
  236.     case N_Identifier:
  237.     case N_Expanded_Name:
  238.     case N_Operator_Symbol:
  239.       /* If the Etype of this node does not equal the Etype of the
  240.      Entity, something is wrong with the entity map, probably
  241.      in generic instantiation.  However, this does not apply to
  242.      types.  Since we sometime have strange Ekind's, just do
  243.      this test for objects.  Also, if the Etype of the Entity
  244.      is private, the Etype of the N_Identifier is allowed to be the
  245.      full type. Finally, if the types are Itypes, one may be a copy
  246.          of the other, which is also legal. */
  247.  
  248.       gnat_temp = Entity (gnat_node);
  249.  
  250.       if (Etype (gnat_node) != Etype (gnat_temp)
  251.       && ! (IN (Ekind (Etype (gnat_temp)), Private_Kind)
  252.         && (Etype (gnat_node)
  253.             == Full_View (Etype (gnat_temp))))
  254.           && (!Is_Itype (Etype (gnat_node)) || !Is_Itype (Etype (gnat_temp)))
  255.       && (Ekind (gnat_temp) == E_Variable
  256.           || Ekind (gnat_temp) == E_Component
  257.           || Ekind (gnat_temp) == E_Constant
  258.           || Ekind (gnat_temp) == E_Loop_Parameter
  259.           || IN (Ekind (gnat_temp), Formal_Kind)))
  260.     {
  261.       gigi_abort (304);
  262.     }
  263.  
  264.       /* Expand the type of this identitier first, in case it is
  265.      an enumeral literal, which only get made when the type
  266.      is expanded.  There is no order-of-elaboration issue here.  */
  267.  
  268.       gnu_result_type = elaborate_node_types (gnat_node);
  269.       gnu_result = gnat_to_gnu_entity (Entity (gnat_node), NULL_TREE, 0);
  270.  
  271.       /* The GNAT tree has the type of a function as the type of its result. */
  272.       if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE)
  273.     gnu_result_type = TREE_TYPE (gnu_result);
  274.  
  275.       /* If we are in an exception handler, force this variable into memory
  276.      to ensure optimization does not remove stores that appear
  277.      redundant but are actually needed in case an exception occurs.  */
  278.       if (gnu_except_ptr_decl != 0)
  279.     mark_addressable (gnu_result);
  280.  
  281.       /* Some objects (such as parameters passed by reference, globals of
  282.      variable size, and renamed objects) actually represent the address
  283.      of the object.  In that case, we must do the dereference unless
  284.      we have a fat pointer.  Call fold here since GNU_RESULT may be
  285.      a CONST_DECL.  */
  286.       if (TREE_CODE_CLASS (TREE_CODE (gnu_result)) == 'd'
  287.       && DECL_BY_REF_P (gnu_result))
  288.     {
  289.       int ro = DECL_POINTS_TO_READONLY_P (gnu_result);
  290.  
  291.       gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
  292.                        fold (gnu_result));
  293.       TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
  294.     }
  295.  
  296.       /* If this type contains a template, extract the underlying object.  */
  297.       if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_result)))
  298.     gnu_result
  299.       = build_component_ref
  300.         (gnu_result, NULL_TREE,
  301.          TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_result))));
  302.  
  303.       /* We always want to return the underlying INTEGER_CST for an
  304.      enumeration literal to avoid the need to call fold in lots
  305.      of places.  */
  306.       if (TREE_CODE (gnu_result) == CONST_DECL)
  307.     gnu_result = DECL_INITIAL (gnu_result);
  308.  
  309.       break;
  310.  
  311.     case N_Integer_Literal:
  312.       gnu_result_type = elaborate_node_types (gnat_node);
  313.       gnu_result = UI_To_gnu (Intval (gnat_node), gnu_result_type);
  314.       if (TREE_CONSTANT_OVERFLOW (gnu_result)
  315. #if 0
  316.       || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type)) == INTEGER_CST
  317.           && tree_int_cst_lt (gnu_result,
  318.                   TYPE_MIN_VALUE (gnu_result_type)))
  319.       || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type)) == INTEGER_CST
  320.           && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type),
  321.                   gnu_result))
  322. #endif
  323.       )
  324.     gigi_abort (305);
  325.       break;
  326.  
  327.     case N_Character_Literal:
  328.       /* If a Entity is present, it means that this was one of the
  329.      literals in a user-defined character type.  In that case,
  330.      just return the value in the CONST_DECL.  Otherwise, use the
  331.      character code.  In that case, the base type should be an
  332.      INTEGER_TYPE, but we won't bother checking for that.  */
  333.       gnu_result_type = elaborate_node_types (gnat_node);
  334.       if (Present (Entity (gnat_node)))
  335.     gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
  336.       else
  337.     gnu_result = build_int_2 (Char_Literal_Value (gnat_node), 0);
  338.       break;
  339.  
  340.     case N_Real_Literal:
  341.       /* If this is of a fixed-point type, the value we want is the
  342.      value of the corresponding integer.  */
  343.       if (IN (Ekind (Etype (gnat_node)), Fixed_Point_Kind))
  344.     {
  345.       gnu_result_type = elaborate_node_types (gnat_node);
  346.       gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
  347.                   gnu_result_type);
  348.       if (TREE_CONSTANT_OVERFLOW (gnu_result)
  349. #if 0
  350.           || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type)) == INTEGER_CST
  351.           && tree_int_cst_lt (gnu_result,
  352.                       TYPE_MIN_VALUE (gnu_result_type)))
  353.           || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type)) == INTEGER_CST
  354.           && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type),
  355.                       gnu_result))
  356. #endif
  357.           )
  358.         gigi_abort (305);
  359.     }
  360.       else
  361.     {
  362.       /* We want to avoid doing explicit host machine arithmetic.  The
  363.          best way to do this is when EXPON_EXPR is implemented, but the
  364.          kludge that follows is the best way for now.   Note that we always
  365.          convert the literal to the largest floating-point type and do
  366.          the arithmetic there, then convert to the result type (at the
  367.          end of this function).  */
  368.  
  369.       tree gnu_numerator = UI_To_gnu (Numerator (Realval (gnat_node)),
  370.                       longest_float_type_node);
  371.       tree gnu_denominator = UI_To_gnu (Denominator (Realval (gnat_node)),
  372.                         longest_float_type_node);
  373.  
  374.       gnu_result = build_binary_op (RDIV_EXPR, longest_float_type_node,
  375.                     gnu_numerator, gnu_denominator);
  376.       gnu_result_type = elaborate_node_types (gnat_node);
  377.     }
  378.       break;
  379.  
  380.     case N_String_Literal:
  381.       {
  382.     /* We assume here that all strings are of type standard.string.
  383.        "Wierd" types of string have been converted to an aggregate
  384.        by the expander and we won't worry about wide characters
  385.        for now.  */
  386.     String_Id gnat_string = Strval (gnat_node);
  387.     int length = String_Length (gnat_string);
  388.     char *string = (char *) alloca (length + 1);
  389.     int i;
  390.  
  391.     /* Build the string with the characters in the literal and
  392.        end it with a null.  Note that Ada strings are 1-origin.  */
  393.     for (i = 0; i < length; i++)
  394.       string[i] = Get_String_Char (gnat_string, i + 1);
  395.  
  396.     string[i] = 0;
  397.     gnu_result = build_string (length, string);
  398.  
  399.     /* Strings in GCC don't normally have types, but we want
  400.        this to not be converted to the array type.  */
  401.     gnu_result_type = elaborate_node_types (gnat_node);
  402.     TREE_TYPE (gnu_result) = gnu_result_type;
  403.       }
  404.       break;
  405.  
  406.     case N_Pragma:
  407.       switch (Get_Pragma_Id (Chars (gnat_node)))
  408.     {
  409.     case Pragma_Inspection_Point:
  410.       set_lineno (gnat_node, 1);
  411.       for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
  412.            Present (gnat_temp);
  413.            gnat_temp = Next (gnat_temp))
  414.         {
  415.           gnu_expr = build1 (USE_EXPR, void_type_node,
  416.                  gnat_to_gnu (Expression ((gnat_temp))));
  417.           TREE_SIDE_EFFECTS (gnu_expr) = 1;
  418.           expand_expr_stmt (gnu_expr);
  419.         }
  420.       break;
  421.  
  422.     case Pragma_Optimize:
  423.       switch (Chars (Expression
  424.              (First (Pragma_Argument_Associations (gnat_node)))))
  425.         {
  426.         case Name_Time:  case Name_Space:
  427.           if (optimize == 0)
  428.         post_error ("insufficient -O value", gnat_node);
  429.           break;
  430.  
  431.         case Name_Off:
  432.           if (optimize != 0)
  433.         post_error ("must specify -O0", gnat_node);
  434.           break;
  435.  
  436.         default:
  437.           gigi_abort (331);
  438.           break;
  439.         }
  440.       break;
  441.  
  442.     case Pragma_Reviewable:
  443.       if (write_symbols == NO_DEBUG)
  444.         post_error ("must specify -g", gnat_node);
  445.       break;
  446.     }
  447.       break;
  448.  
  449.     /**************************************/
  450.     /* Chapter 3: Declarations and Types: */
  451.     /**************************************/
  452.  
  453.     case N_Implicit_Types:
  454.       process_implicit_types (gnat_node);
  455.       break;
  456.  
  457.     case N_Subtype_Declaration:
  458.       if (Present (Subtype_Indication (gnat_node))
  459.       && IN (Nkind (Subtype_Indication (gnat_node)), N_Has_Itypes))
  460.     process_implicit_types (Subtype_Indication (gnat_node));
  461.  
  462.       /* ... fall through ... */
  463.  
  464.     case N_Full_Type_Declaration:
  465.     case N_Incomplete_Type_Declaration:
  466.     case N_Private_Type_Declaration:
  467.     case N_Private_Extension_Declaration:
  468.     case N_Task_Type_Declaration:
  469.       process_implicit_types (gnat_node);
  470.       process_type (Defining_Identifier (gnat_node));
  471.       break;
  472.  
  473.     case N_Object_Declaration:
  474.     case N_Exception_Declaration:
  475.       gnat_temp = Defining_Identifier (gnat_node);
  476.  
  477.       if (Present (Expression (gnat_node)))
  478.     {
  479.       gnu_expr = gnat_to_gnu (Expression (gnat_node));
  480.       if (Do_Range_Check (Expression (gnat_node)))
  481.         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
  482.  
  483.       /* If this object has its elaboration delayed, we must force
  484.          evaluation of GNU_EXPR right now and save it for when the object
  485.          is frozen.  */
  486.       if (Present (Freeze_Node (gnat_temp)))
  487.         {
  488.           if ((Is_Public (gnat_temp) || global_bindings_p ())
  489.           && ! TREE_CONSTANT (gnu_expr))
  490.         gnu_expr
  491.           = create_var_decl (create_concat_name (gnat_temp, "init"),
  492.                      NULL_PTR, TREE_TYPE (gnu_expr), gnu_expr,
  493.                      NULL_TREE, 0, 0, Is_Public (gnat_temp),
  494.                      0, 0);
  495.           else
  496.         gnu_expr = maybe_variable (gnu_expr);
  497.  
  498.           save_gnu_tree (gnat_node, gnu_expr, 1);
  499.         }
  500.     }
  501.       else
  502.     gnu_expr = NULL_TREE;
  503.  
  504.       process_implicit_types (gnat_node);
  505.  
  506.       if (No (Freeze_Node ((gnat_temp))))
  507.     gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
  508.       break;
  509.  
  510.     case N_Object_Renaming_Declaration:
  511.       gnat_temp = Defining_Identifier (gnat_node);
  512.       gnu_expr = gnat_to_gnu (Renamed_Object (gnat_temp));
  513.       gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
  514.       process_implicit_types (gnat_node);
  515.       break;
  516.  
  517.     case N_Implicit_Label_Declaration:
  518.       gnat_to_gnu_entity (Defining_Identifier (gnat_node), NULL_TREE, 1);
  519.       process_implicit_types (gnat_node);
  520.       break;
  521.  
  522.     case N_Subprogram_Renaming_Declaration:
  523.     case N_Package_Renaming_Declaration:
  524.     case N_Exception_Renaming_Declaration:
  525.     case N_Number_Declaration:
  526.       /* These are fully handled in the front end.  */
  527.       process_implicit_types (gnat_node);
  528.       break;
  529.  
  530.     /*************************************/
  531.     /* Chapter 4: Names and Expressions: */
  532.     /*************************************/
  533.  
  534.     case N_Explicit_Dereference:
  535.       gnu_result = gnat_to_gnu (Prefix (gnat_node));
  536.       gnu_result_type = elaborate_node_types (gnat_node);
  537.  
  538.       /* Emit access check if necessary */
  539.       if (Do_Access_Check (gnat_node))
  540.     gnu_result = emit_access_check (gnu_result);
  541.  
  542.       gnu_result = build_unary_op (INDIRECT_REF, gnu_result_type, gnu_result);
  543.       break;
  544.  
  545.     case N_Indexed_Component:
  546.       {
  547.     tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
  548.     tree gnu_type;
  549.     int ndim;
  550.     int i;
  551.     Node_Id *gnat_expr_array;
  552.  
  553.     /* Emit access check if necessary */
  554.     if (Do_Access_Check (gnat_node))
  555.       gnu_array_object = emit_access_check (gnu_array_object);
  556.  
  557.     gnu_array_object = maybe_implicit_deref (gnu_array_object);
  558.     gnu_array_object = maybe_unconstrained_array (gnu_array_object);
  559.     gnu_result = gnu_array_object;
  560.  
  561.     /* First compute the number of dimensions of the array, then
  562.        fill the expression array, the order depending on whether
  563.        this is a Convention_Fortran array or not.  */
  564.     for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
  565.          TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
  566.          && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
  567.          ndim++, gnu_type = TREE_TYPE (gnu_type))
  568.       ;
  569.  
  570.     gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
  571.  
  572.     if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_type)))
  573.       for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
  574.            i >= 0;
  575.            i--, gnat_temp = Next (gnat_temp))
  576.         gnat_expr_array[i] = gnat_temp;
  577.     else
  578.       for (i = 0, gnat_temp = First (Expressions (gnat_node));
  579.            i < ndim;
  580.            i++, gnat_temp = Next (gnat_temp))
  581.         gnat_expr_array[i] = gnat_temp;
  582.  
  583.     for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
  584.          i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
  585.       {
  586.         if (TREE_CODE (gnu_type) != ARRAY_TYPE)
  587.           gigi_abort (307);
  588.  
  589.         gnat_temp = gnat_expr_array[i];
  590.         gnu_expr = gnat_to_gnu (gnat_temp);
  591.  
  592.         if (Do_Range_Check (gnat_temp))
  593.           gnu_expr
  594.         = emit_index_check
  595.           (gnu_array_object, gnu_expr,
  596.            TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
  597.            TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
  598.  
  599.         gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
  600.                       gnu_result, gnu_expr);
  601.       }
  602.       }
  603.  
  604.       gnu_result_type = elaborate_node_types (gnat_node);
  605.       break;
  606.  
  607.     case N_Slice:
  608.       {
  609.         tree gnu_type;
  610.         tree gnu_expr_l, gnu_expr_h;
  611.         Node_Id gnat_range_node = Range (gnat_node);
  612.  
  613.         gnu_result = gnat_to_gnu (Prefix (gnat_node));
  614.         gnu_result_type = elaborate_node_types (gnat_node);
  615.  
  616.         /* Emit access check if necessary */
  617.         if (Do_Access_Check (gnat_node))
  618.           gnu_result = emit_access_check (gnu_result);
  619.  
  620.         /* Reference the desired first component of Prefix, where the first
  621.            index is the low bound of our type.  Then takes its address and
  622.            convert it to a pointer to our type.  Finally, indirectly
  623.            reference that.  Note that most of these operations are just
  624.            performed to get the types correct and will go away.  */
  625.         gnu_result = maybe_implicit_deref (gnu_result);
  626.         gnu_result = maybe_unconstrained_array (gnu_result);
  627.         gnu_type = TREE_TYPE (gnu_result);
  628.         if (Do_Range_Check (gnat_range_node)) 
  629.           {
  630.             /* Get the bounds of the slice. */
  631.         tree gnu_index_type
  632.           = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
  633.             tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
  634.             tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
  635.             tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
  636.  
  637.             /* Check to see that the minimum slice value is in range */
  638.             gnu_expr_l
  639.           = emit_index_check
  640.         (gnu_result, gnu_min_expr,
  641.          TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
  642.          TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
  643.  
  644.             /* Check to see that the maximum slice value is in range */
  645.             gnu_expr_h
  646.           = emit_index_check
  647.         (gnu_result, gnu_max_expr,
  648.          TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
  649.          TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
  650.  
  651.             /* Derive a good type to convert everything too */
  652.             gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
  653.  
  654.             /* Build a compound expression that does the range checks */
  655.             gnu_expr
  656.               = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
  657.                                  convert (gnu_expr_type, gnu_expr_h),
  658.                                  convert (gnu_expr_type, gnu_expr_l));
  659.  
  660.             /* Build a conditional expression that returns the range checks
  661.                expression if the slice range is not null (max >= min) or
  662.                returns the min if the slice range is null */
  663.             gnu_expr
  664.               = build (COND_EXPR, gnu_expr_type,
  665.                build_binary_op (GE_EXPR, gnu_expr_type,
  666.                     convert (gnu_expr_type, gnu_max_expr),
  667.                     convert (gnu_expr_type, gnu_min_expr)),
  668.                gnu_expr, gnu_min_expr);
  669.           }
  670.         else
  671.           gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
  672.  
  673.         gnu_result 
  674.           = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
  675.         gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
  676.         gnu_result 
  677.           = convert (build_pointer_type (gnu_result_type), gnu_result);
  678.         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
  679.       }
  680.       break;
  681.  
  682.     case N_Selected_Component:
  683.       {
  684.     tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
  685.     Entity_Id gnat_field = Selector_Name (gnat_node);
  686.         char *gnat_field_name = Get_Name_String (Chars (gnat_field));
  687.     tree gnu_field = gnat_to_gnu (gnat_field);
  688.         Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
  689.  
  690.     /* If there are discriminants, the prefix might be evaluated more
  691.        than once, which is a problem if it has side-effe1cts.  */
  692.     if (Has_Discriminants (Prefix (gnat_node))
  693.         && TREE_SIDE_EFFECTS (gnu_prefix))
  694.       gnu_prefix = make_save_expr (gnu_prefix);
  695.  
  696.     /* emit access and discriminant check if necessary */
  697.     if (Do_Access_Check (gnat_node))
  698.       gnu_prefix = emit_access_check (gnu_prefix);
  699.     if (Do_Discriminant_Check (gnat_node))
  700.       gnu_prefix = emit_discriminant_check (gnu_prefix,
  701.                         gnat_node);
  702.     gnu_result =
  703.       build_component_ref (gnu_prefix,
  704.                    get_identifier (gnat_field_name),
  705.                    gnu_field);
  706.     if (gnu_result == 0)
  707.       gigi_abort (308);
  708.  
  709.     gnu_result_type = elaborate_node_types (gnat_node);
  710.       }
  711.       break;
  712.  
  713.     case N_Attribute_Reference:
  714.       {
  715.         /* The attribute designator (like an enumeration value). */
  716.         int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
  717.     int prefix_unused = 0;
  718.     tree gnu_prefix;
  719.     tree gnu_type;
  720.  
  721.     /* The Elab_Spec and Elab_Body attributes are special in that
  722.        Prefix is a unit, not an object with a GCC equivalent.  */
  723.     if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
  724.       return
  725.         create_subprog_decl
  726.           (create_concat_name (Entity (Prefix (gnat_node)),
  727.                    attribute == Attr_Elab_Body
  728.                    ? "elabb" : "elabs"),
  729.            0, void_ftype, NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  730.  
  731.     gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
  732.     gnu_type = TREE_TYPE (gnu_prefix);
  733.  
  734.         switch (attribute)
  735.           {
  736.       case Attr_Pos:
  737.       case Attr_Val:
  738.         /* These are just conversions until since representation
  739.            clauses for enumerations are handled in the front end.  */
  740.         gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
  741.         gnu_result_type = elaborate_node_types (gnat_node);
  742.         if (Do_Range_Check (First (Expressions (gnat_node))))
  743.           gnu_result
  744.         = emit_range_check (convert (gnu_result_type, gnu_result),
  745.                     Etype (gnat_node));
  746.         break;
  747.  
  748.       case Attr_Pred:
  749.       case Attr_Succ:
  750.         /* These just add or subject the constant 1.  Representation
  751.            clauses for enumerations are handled in the front-end.  */
  752.         gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
  753.         gnu_result_type = elaborate_node_types (gnat_node);
  754.  
  755.         if (Do_Range_Check (First (Expressions (gnat_node))))
  756.           {
  757.         gnu_expr = make_save_expr (gnu_expr);
  758.         gnu_expr
  759.           = emit_check
  760.             (build_binary_op (EQ_EXPR, integer_type_node,
  761.                       gnu_expr,
  762.                       attribute == Attr_Pred
  763.                       ? TYPE_MIN_VALUE (gnu_result_type)
  764.                       : TYPE_MAX_VALUE (gnu_result_type)),
  765.              gnu_expr);
  766.           }
  767.  
  768.         gnu_result
  769.           = build_binary_op (attribute == Attr_Pred
  770.                  ? MINUS_EXPR : PLUS_EXPR,
  771.                  gnu_result_type, gnu_expr,
  772.                  convert (gnu_result_type, integer_one_node));
  773.         break;
  774.  
  775.       case Attr_Address:
  776.  
  777.         /* If we are taking 'Address of an unconstrained object,
  778.            this is the pointer to the underlying array.  */
  779.         if (TREE_CODE (gnu_prefix) == UNCONSTRAINED_ARRAY_REF)
  780.           {
  781.         tree gnu_fat_pointer = TREE_OPERAND (gnu_prefix, 0);
  782.         tree gnu_fat_type = TREE_TYPE (gnu_fat_pointer);
  783.  
  784.         gnu_result_type = elaborate_node_types (gnat_node);
  785.         gnu_result
  786.           = build_component_ref (gnu_fat_pointer, NULL_TREE,
  787.                      TYPE_FIELDS (gnu_fat_type));
  788.         break;
  789.           }
  790.  
  791.         /* ... fall through ... */
  792.  
  793.           case Attr_Access:
  794.           case Attr_Unchecked_Access:
  795.           case Attr_Unrestricted_Access:
  796.  
  797.         gnu_result_type = elaborate_node_types (gnat_node);
  798.         gnu_result = build_unary_op (ADDR_EXPR, gnu_result_type,
  799.                      gnu_prefix);
  800.         break;
  801.  
  802.       case Attr_Size:
  803.         if (TREE_CODE_CLASS (TREE_CODE (gnu_prefix)) == 'd'
  804.         && TREE_CODE (gnu_prefix) != TYPE_DECL)
  805.           gnu_result = DECL_SIZE (gnu_prefix), prefix_unused = 1;
  806.  
  807.         /* If this is an itegral type, return the precision, else
  808.            the size.  */
  809.         else if (INTEGRAL_TYPE_P (gnu_type))
  810.           {
  811.         gnu_result = build_int_2 (TYPE_PRECISION (gnu_type), 0);
  812.         prefix_unused = 1;
  813.           }
  814.         else
  815.           {
  816.         /* First replace an unconstrained array type with the
  817.            type of the underlying array.  Then, in all cases,
  818.            deal with a varying size by returning the maximum
  819.            size for a type and by qualifying the size with
  820.            the object for 'Size of an object.  */
  821.  
  822.         if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
  823.           {
  824.             tree gnu_p_array = TYPE_FIELDS (TREE_TYPE (gnu_type));
  825.  
  826.             gnu_type = TREE_TYPE (TREE_TYPE (gnu_p_array));
  827.           }
  828.  
  829.         gnu_result = TYPE_SIZE (gnu_type);
  830.         if (TREE_CODE (gnu_result) != INTEGER_CST
  831.             && contains_placeholder_p (gnu_result))
  832.           {
  833.             if (TREE_CODE (gnu_prefix) != TYPE_DECL)
  834.               gnu_result
  835.             = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
  836.                  gnu_result, gnu_prefix);
  837.             else
  838.               gnu_result = max_size (TYPE_SIZE (gnu_type), 1);
  839.           }
  840.         else
  841.           prefix_unused = 1;
  842.           }
  843.  
  844.         gnu_result_type = elaborate_node_types (gnat_node);
  845.         break;
  846.  
  847.       case Attr_Alignment:
  848.         if (TREE_CODE_CLASS (TREE_CODE (gnu_prefix)) == 'd'
  849.         && TREE_CODE (gnu_prefix) != TYPE_DECL)
  850.           gnu_result
  851.         = build_int_2 (DECL_ALIGN (gnu_prefix) / BITS_PER_UNIT, 0);
  852.         else
  853.           gnu_result
  854.         = build_int_2 (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT, 0);
  855.  
  856.         prefix_unused = 1;
  857.         gnu_result_type = elaborate_node_types (gnat_node);
  858.         break;
  859.  
  860.       case Attr_First:
  861.       case Attr_Last:
  862.       case Attr_Range_Length:
  863.         prefix_unused = 1;
  864.  
  865.         if (INTEGRAL_TYPE_P (gnu_type)
  866.         || TREE_CODE (gnu_type) == REAL_TYPE)
  867.           {
  868.         gnu_result_type = elaborate_node_types (gnat_node);
  869.  
  870.         if (attribute == Attr_First)
  871.           gnu_result = TYPE_MIN_VALUE (gnu_type);
  872.         else if (attribute == Attr_Last)
  873.           gnu_result = TYPE_MAX_VALUE (gnu_type);
  874.         else
  875.           gnu_result
  876.             = build_binary_op
  877.               (MAX_EXPR, get_base_type (gnu_result_type),
  878.                build_binary_op
  879.                (PLUS_EXPR, get_base_type (gnu_result_type),
  880.             build_binary_op (MINUS_EXPR,
  881.                      get_base_type (gnu_result_type),
  882.                      convert (gnu_result_type,
  883.                           TYPE_MAX_VALUE (gnu_type)),
  884.                      convert (gnu_result_type,
  885.                           TYPE_MIN_VALUE (gnu_type))),
  886.             convert (gnu_result_type, integer_one_node)),
  887.                convert (gnu_result_type, integer_zero_node));
  888.  
  889.         break;
  890.           }
  891.         /* ... fall through ... */
  892.       case Attr_Length:
  893.         {
  894.           int Dimension
  895.         = (Present (Expressions (gnat_node))
  896.            ? UI_To_Int (Intval (First (Expressions (gnat_node))))
  897.            : 1);
  898.           gnu_result_type = elaborate_node_types (gnat_node);
  899.  
  900.           /* Emit access check if necessary */
  901.           if (Do_Access_Check (gnat_node))
  902.         gnu_prefix = emit_access_check (gnu_prefix);
  903.  
  904.           /* Make sure any implicit dereference gets done.  */
  905.           gnu_prefix = maybe_implicit_deref (gnu_prefix);
  906.           gnu_prefix = maybe_unconstrained_array (gnu_prefix);
  907.           gnu_type = TREE_TYPE (gnu_prefix);
  908.  
  909.           if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
  910.         {
  911.           int ndim;
  912.           tree gnu_type_temp;
  913.  
  914.           for (ndim = 1, gnu_type_temp = gnu_type;
  915.                TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
  916.                && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
  917.                ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
  918.             ;
  919.  
  920.           Dimension = ndim + 1 - Dimension;
  921.         }
  922.  
  923.           for (; Dimension > 1; Dimension--)
  924.         gnu_type = TREE_TYPE (gnu_type);
  925.  
  926.           if (TREE_CODE (gnu_type) != ARRAY_TYPE)
  927.         gigi_abort (309);
  928.  
  929.           if (attribute == Attr_First)
  930.         gnu_result
  931.           = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
  932.           else if (attribute == Attr_Last)
  933.         gnu_result
  934.           = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
  935.           else
  936.         /* 'Length or 'Range_Length.  */
  937.         gnu_result
  938.           = build_binary_op
  939.             (MAX_EXPR, get_base_type (gnu_result_type),
  940.              build_binary_op
  941.              (PLUS_EXPR, get_base_type (gnu_result_type),
  942.               build_binary_op 
  943.                       (MINUS_EXPR, get_base_type (gnu_result_type),
  944.                convert (gnu_result_type,
  945.                 TYPE_MAX_VALUE (TYPE_DOMAIN (gnu_type))),
  946.                convert (gnu_result_type,
  947.                 TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_type)))),
  948.               convert (gnu_result_type, integer_one_node)),
  949.              convert (gnu_result_type, integer_zero_node));
  950.  
  951.           /* If this has a PLACEHOLDER_EXPR, qualify it by the object
  952.          we are handling.  Note that these attributes could not
  953.          have been used on an unconstrained array type.  */
  954.           if (TREE_CODE (gnu_result) != INTEGER_CST
  955.           && contains_placeholder_p (gnu_result))
  956.         gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
  957.                     gnu_result, gnu_prefix);
  958.           else
  959.         prefix_unused = 1;
  960.  
  961.           break;
  962.         }
  963.  
  964.       case Attr_Position:
  965.       case Attr_First_Bit:
  966.       case Attr_Last_Bit:
  967.         {
  968.           int bitsize, bitpos;
  969.           tree offset;
  970.           enum machine_mode mode;
  971.           int unsignedp, volatilep;
  972.  
  973.           if (TREE_CODE (gnu_prefix) != COMPONENT_REF)
  974.         gigi_abort (310);
  975.  
  976.           gnu_prefix = get_inner_reference (gnu_prefix, &bitsize, &bitpos,
  977.                         &offset, &mode, &unsignedp,
  978.                         &volatilep);
  979.  
  980.           prefix_unused = 1;
  981.  
  982.           if (offset)
  983.         offset = size_binop (PLUS_EXPR, offset, size_int (bitpos));
  984.           else
  985.         offset = size_int (bitpos);
  986.  
  987.           if (attribute == Attr_Position)
  988.         gnu_result = size_binop (TRUNC_DIV_EXPR, offset,
  989.                      size_int (BITS_PER_UNIT));
  990.           else if (attribute == Attr_First_Bit)
  991.         gnu_result = size_binop (TRUNC_MOD_EXPR, offset,
  992.                      size_int (BITS_PER_UNIT));
  993.           else if (attribute == Attr_Last_Bit)
  994.         gnu_result = size_binop (PLUS_EXPR,
  995.                      size_binop (TRUNC_MOD_EXPR, offset,
  996.                              size_int (BITS_PER_UNIT)),
  997.                      size_int (bitsize - 1));
  998.         }
  999.  
  1000.         gnu_result_type = elaborate_node_types (gnat_node);
  1001.         break;
  1002.  
  1003.       case Attr_Min:
  1004.       case Attr_Max:
  1005.         {
  1006.           tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
  1007.           tree gnu_rhs
  1008.         =  gnat_to_gnu (Next (First (Expressions (gnat_node))));
  1009.  
  1010.           gnu_result_type = elaborate_node_types (gnat_node);
  1011.           gnu_result = build_binary_op (attribute == Attr_Min
  1012.                         ? MIN_EXPR : MAX_EXPR,
  1013.                         gnu_result_type, gnu_lhs, gnu_rhs);
  1014.         }
  1015.         break;
  1016.  
  1017.       case Attr_Passed_By_Reference:
  1018.         gnu_result = build_int_2 (pass_by_ref (gnu_type), 0);
  1019.         gnu_result_type = elaborate_node_types (gnat_node);
  1020.         break;
  1021.  
  1022.       case Attr_Component_Size:
  1023.         if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
  1024.           gnu_type
  1025.         = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
  1026.  
  1027.         while (TREE_CODE (gnu_type) == ARRAY_TYPE
  1028.            && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
  1029.           gnu_type = TREE_TYPE (gnu_type);
  1030.  
  1031.         if (TREE_CODE (gnu_type) != ARRAY_TYPE)
  1032.           gigi_abort (330);
  1033.  
  1034.         /* Note this size cannot be self-referential.  */
  1035.         gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
  1036.         gnu_result_type = elaborate_node_types (gnat_node);
  1037.         prefix_unused = 1;
  1038.         break;
  1039.  
  1040.           default:
  1041.         /* Say we have an unimplemented attribute.  Then set the
  1042.            value to be returned to be a zero and hope that's something
  1043.            we can convert to the type of this attribute.  */
  1044.  
  1045.         post_error ("unimplemented attribute", gnat_node);
  1046.         gnu_result_type = elaborate_node_types (gnat_node);
  1047.         gnu_result = integer_zero_node;
  1048.         break;
  1049.           }
  1050.  
  1051.     /* If this is an attribute where the prefix was unused,
  1052.        force a use of it if it has a side-effect.  */
  1053.     if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix))
  1054.       gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result),
  1055.                     gnu_prefix, gnu_result));
  1056.       }
  1057.       break;
  1058.  
  1059.     case N_Reference:
  1060.       {
  1061.     /* Like 'Access as far as we are concerned.  */
  1062.         tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
  1063.  
  1064.     gnu_result_type = elaborate_node_types (gnat_node);
  1065.     gnu_result = build_unary_op (ADDR_EXPR, gnu_result_type,
  1066.                      gnu_prefix);
  1067.       }
  1068.       break;
  1069.  
  1070.     case N_Aggregate:
  1071.     case N_Extension_Aggregate:
  1072.  
  1073.       /* ??? It is wrong to evaluate the type now, but there doesn't
  1074.      seem to be any other practical way of doing it.  */
  1075.  
  1076.       gnu_result_type = elaborate_node_types (gnat_node);
  1077.       if (TREE_CODE (gnu_result_type) == RECORD_TYPE)
  1078.     gnu_result
  1079.       = assoc_to_constructor (First (Component_Associations (gnat_node)),
  1080.                   gnu_result_type, NULL_TREE);
  1081.       else if (TREE_CODE (gnu_result_type) == ARRAY_TYPE)
  1082.     gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
  1083.                      gnu_result_type,
  1084.                      Component_Type (Etype (gnat_node)));
  1085.       else
  1086.     gigi_abort (312);
  1087.       break;
  1088.  
  1089.     case N_Null:
  1090.       gnu_result = null_pointer_node;
  1091.       gnu_result_type = elaborate_node_types (gnat_node);
  1092.       break;
  1093.  
  1094.     case N_Type_Conversion:
  1095.       /* Get the operand expression.  */
  1096.       gnu_result = gnat_to_gnu (Expression (gnat_node));
  1097.       gnu_result_type = elaborate_node_types (gnat_node);
  1098.  
  1099.       /* If a overflow check is needed, emit code to generate it. Note that
  1100.      this check is against the base type of the result and must only
  1101.      be done if the expression type is wider than that base type.  */
  1102.       if (Do_Overflow_Check (gnat_node)
  1103.       && INTEGRAL_TYPE_P (gnu_result_type)
  1104.       && (TYPE_PRECISION (gnu_result_type)
  1105.           < TYPE_PRECISION (TREE_TYPE (gnu_result)))
  1106.       && (TREE_UNSIGNED (gnu_result_type)
  1107.           == TREE_UNSIGNED (TREE_TYPE (gnu_result)))
  1108.       && ! (TREE_TYPE (TREE_TYPE (gnu_result)) != 0
  1109.         && TYPE_MODULAR_P (TREE_TYPE (TREE_TYPE (gnu_result)))
  1110.         && ! (tree_int_cst_lt
  1111.               (TYPE_MAX_VALUE (get_base_type (gnu_result_type)),
  1112.                TYPE_MODULUS (TREE_TYPE (TREE_TYPE (gnu_result)))))))
  1113.     gnu_result =
  1114.       emit_range_check (gnu_result,
  1115.                 Base_Type (Entity (Subtype_Mark (gnat_node))));
  1116.  
  1117.       /* Do the explicit conversion.  Don't assume that the general
  1118.      code on our exit will do it since there are many exceptions
  1119.      to doing conversion there, some of which apply here.  */
  1120.       gnu_result = convert (gnu_result_type, gnu_result);
  1121.  
  1122.       /* If a range check is needed, emit code to generate it. */
  1123.       if (Do_Range_Check (Expression (gnat_node)))
  1124.     gnu_result
  1125.       = emit_range_check (gnu_result,
  1126.                   Entity (Subtype_Mark (gnat_node)));
  1127.  
  1128.       break;
  1129.  
  1130.     case N_Unchecked_Type_Conversion:
  1131.       gnu_result = gnat_to_gnu (Expression (gnat_node));
  1132.       gnu_result_type = elaborate_node_types (gnat_node);
  1133.       gnu_result = unchecked_convert (gnu_result_type, gnu_result);
  1134.       break;
  1135.  
  1136.     case N_Qualified_Expression:
  1137.  
  1138.       /* Just get the operand expression.  The conversion at the end
  1139.      of this function will do the actual operation.  */
  1140.       gnu_result = gnat_to_gnu (Expression (gnat_node));
  1141.       gnu_result_type = elaborate_node_types (gnat_node);
  1142.       break;
  1143.  
  1144.     case N_In:
  1145.     case N_Not_In:
  1146.       {
  1147.     tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
  1148.     Node_Id gnat_range = Right_Opnd (gnat_node);
  1149.     tree gnu_low;
  1150.     tree gnu_high;
  1151.  
  1152.     /* GNAT_RANGE is either an N_Range node or an identifier
  1153.        denoting a subtype.  */
  1154.     if (Nkind (gnat_range) == N_Range)
  1155.       {
  1156.         gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
  1157.         gnu_high = gnat_to_gnu (High_Bound (gnat_range));
  1158.       }
  1159.     else if (Nkind (gnat_range) == N_Identifier
  1160.               || Nkind (gnat_range) == N_Expanded_Name)
  1161.       {
  1162.         tree gnu_range_type = gnat_to_gnu_type (Entity (gnat_range));
  1163.  
  1164.         gnu_low = TYPE_MIN_VALUE (gnu_range_type);
  1165.         gnu_high = TYPE_MAX_VALUE (gnu_range_type);
  1166.       }
  1167.     else
  1168.       gigi_abort (313);
  1169.  
  1170.     gnu_result_type = elaborate_node_types (gnat_node);
  1171.  
  1172.     /* If LOW and HIGH are identical, perform an equality test.
  1173.        Otherwise, ensure that GNU_OBJECT is only evaluated once
  1174.        and perform a full range test.  */
  1175.     if (operand_equal_p (gnu_low, gnu_high, 0))
  1176.       gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
  1177.                     gnu_object, gnu_low);
  1178.     else
  1179.       {
  1180.         gnu_object = make_save_expr (gnu_object);
  1181.         gnu_result
  1182.           = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
  1183.                  build_binary_op (GE_EXPR, gnu_result_type,
  1184.                           gnu_object, gnu_low),
  1185.                  build_binary_op (LE_EXPR, gnu_result_type,
  1186.                           gnu_object, gnu_high));
  1187.       }
  1188.  
  1189.     if (Nkind (gnat_node) == N_Not_In)
  1190.       gnu_result = invert_truthvalue (gnu_result);
  1191.       }
  1192.       break;
  1193.  
  1194.     case N_Op_Divide:
  1195.       {
  1196.     tree gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
  1197.     tree gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
  1198.  
  1199.     gnu_result_type = elaborate_node_types (gnat_node);
  1200.     gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
  1201.                       ? RDIV_EXPR
  1202.                       : (Rounded_Result (gnat_node)
  1203.                      ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
  1204.                       gnu_result_type, gnu_lhs, gnu_rhs);
  1205.       }
  1206.       break;
  1207.  
  1208.     case N_Op_Or:    case N_Op_And:      case N_Op_Xor:
  1209.       /* These can either be operations on booleans or on modular types.
  1210.      Fall through for boolean types since that's the way GNU_CODES is
  1211.      set up.  */
  1212.       if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
  1213.     {
  1214.       enum tree_code code
  1215.         = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
  1216.            : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
  1217.            : BIT_XOR_EXPR);
  1218.       tree gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
  1219.       tree gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
  1220.  
  1221.       gnu_result_type = elaborate_node_types (gnat_node);
  1222.       gnu_result = build_binary_op (code, gnu_result_type,
  1223.                     gnu_lhs, gnu_rhs);
  1224.       break;
  1225.     }
  1226.  
  1227.       /* ... fall through ... */
  1228.  
  1229.     case N_Op_Eq:    case N_Op_Ne:     case N_Op_Lt:
  1230.     case N_Op_Le:    case N_Op_Gt:       case N_Op_Ge:
  1231.     case N_Op_Add:   case N_Op_Subtract: case N_Op_Multiply:
  1232.     case N_Op_Mod:   case N_Op_Rem:     case N_Op_Expon:
  1233.     case N_And_Then: case N_Or_Else:
  1234.     case N_Op_Rotate_Left:
  1235.     case N_Op_Rotate_Right:
  1236.     case N_Op_Shift_Left:
  1237.     case N_Op_Shift_Right:
  1238.     case N_Op_Shift_Right_Arithmetic:
  1239.       {
  1240.     enum tree_code code = gnu_codes[Nkind (gnat_node)];
  1241.     tree gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
  1242.     tree gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
  1243.     tree gnu_type;
  1244.  
  1245.     gnu_type = gnu_result_type = elaborate_node_types (gnat_node);
  1246.  
  1247.     /* If this is a comparison operator, convert any references to
  1248.        an unconstrained array value into a reference to the
  1249.        actual array.  */
  1250.     if (TREE_CODE_CLASS (code) == '<')
  1251.       {
  1252.         gnu_lhs = maybe_unconstrained_array (gnu_lhs);
  1253.         gnu_rhs = maybe_unconstrained_array (gnu_rhs);
  1254.       }
  1255.  
  1256.     /* For right shifts, the type says what kind of shift to do,
  1257.        so we may need to choose a different type.  */
  1258.     if (Nkind (gnat_node) == N_Op_Shift_Right
  1259.         && ! TREE_UNSIGNED (gnu_type))
  1260.       gnu_type = unsigned_type (gnu_type);
  1261.     else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
  1262.          && TREE_UNSIGNED (gnu_type))
  1263.       gnu_type = signed_type (gnu_type);
  1264.  
  1265.     if (gnu_type != gnu_result_type)
  1266.       {
  1267.         gnu_lhs = convert (gnu_type, gnu_lhs);
  1268.         gnu_rhs = convert (gnu_type, gnu_rhs);
  1269.       }
  1270.  
  1271.     gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
  1272.       }
  1273.       break;
  1274.  
  1275.     case N_Conditional_Expression:
  1276.       {
  1277.         tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
  1278.         tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
  1279.         tree gnu_false
  1280.           = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
  1281.  
  1282.     gnu_result_type = elaborate_node_types (gnat_node);
  1283.         gnu_result = build_cond_expr (gnu_result_type,
  1284.                       truthvalue_conversion (gnu_cond),
  1285.                       gnu_true, gnu_false);
  1286.       }
  1287.       break;
  1288.  
  1289.     case N_Op_Plus:
  1290.       gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
  1291.       gnu_result_type = elaborate_node_types (gnat_node);
  1292.       break;
  1293.  
  1294.     case N_Op_Not:
  1295.       /* This case can apply to a boolean or a modular type.
  1296.      Fall through for a boolean operand since GNU_CODES is set
  1297.      up to handle this.  */
  1298.       if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
  1299.     {
  1300.       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
  1301.       gnu_result_type = elaborate_node_types (gnat_node);
  1302.       gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
  1303.                        gnu_expr);
  1304.       break;
  1305.     }
  1306.  
  1307.       /* ... fall through ... */
  1308.  
  1309.     case N_Op_Minus:  case N_Op_Abs:
  1310.       gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
  1311.       gnu_result_type = elaborate_node_types (gnat_node);
  1312.       gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
  1313.                    gnu_result_type, gnu_expr);
  1314.       break;
  1315.  
  1316.     case N_Allocator:
  1317.       {
  1318.     tree gnu_init = 0;
  1319.     Entity_Id gnat_type;
  1320.     tree gnu_type;
  1321.  
  1322.     gnat_temp = Expression (gnat_node);
  1323.  
  1324.     /* The Expression operand can either be an N_Identifier or
  1325.        Expanded_Name, which must represent a type, or a
  1326.        N_Qualified_Expression, which contains both the object type and an
  1327.        initial value for the object.  */
  1328.     if (Nkind (gnat_temp) == N_Identifier
  1329.         || Nkind (gnat_temp) == N_Expanded_Name)
  1330.       gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
  1331.     else if (Nkind (gnat_temp) == N_Qualified_Expression)
  1332.       {
  1333.         gnu_init = gnat_to_gnu (Expression (gnat_temp));
  1334.         gnu_init = maybe_unconstrained_array (gnu_init);
  1335.         gnu_type = TREE_TYPE (gnu_init);
  1336.       }
  1337.     else
  1338.       gigi_abort (315);
  1339.  
  1340.     gnu_result_type = elaborate_node_types (gnat_node);
  1341.     return build_allocator (gnu_type, gnu_init, gnu_result_type,
  1342.                 Procedure_To_Call (gnat_node),
  1343.                 Storage_Pool (gnat_node));
  1344.       }
  1345.       break;
  1346.  
  1347.     case N_Expression_Actions:
  1348.       /* Start an expression statement, preform any actions specified in
  1349.      the node, expand our expression, and then end the statement.
  1350.      If we are not within any subprogram, we cannot actually generate
  1351.      RTL, so make a TRANSFORM_EXPR if there is anything unusual in
  1352.      the actions.  Note that we don't know our own type in that
  1353.      case, but convert knows what to do.
  1354.  
  1355.      ??? There is a potential problem here if our type is declared
  1356.      inside this node and is used in the containing expression and
  1357.      this occurs at the global level and in a node that has
  1358.      nontrivial actions.  I don't think that actually occurs, so we
  1359.      might be lucky.  */
  1360.  
  1361.       if (global_bindings_p ())
  1362.     {
  1363.       for (gnat_temp = First (Actions (gnat_node)); gnat_temp;
  1364.            gnat_temp = Next (gnat_temp))
  1365.         switch (Nkind (gnat_temp))
  1366.           {
  1367.           case N_Implicit_Types:
  1368.           case N_Full_Type_Declaration:
  1369.           case N_Task_Type_Declaration:
  1370.           case N_Subtype_Declaration:
  1371.           case N_Number_Declaration:
  1372.           case N_Object_Declaration:
  1373.           case N_Exception_Declaration:
  1374.         break;
  1375.           default:
  1376.         return make_transform_expr (gnat_node, error_mark_node);
  1377.           }
  1378.     }
  1379.  
  1380.       /* ??? For now, if at top level, don't make an RTL_EXPR.  That
  1381.      assumes that we don't try to make any SAVE_EXPRs in our
  1382.      implicit types or actions, but we have no other choice right
  1383.      now.  */
  1384.  
  1385.       if (! global_bindings_p ())
  1386.     gnu_result = expand_start_stmt_expr ();
  1387.  
  1388.       for (gnat_temp = First (Actions (gnat_node)); gnat_temp;
  1389.        gnat_temp = Next (gnat_temp))
  1390.     gnat_to_code (gnat_temp);
  1391.  
  1392.       /* Now that we've defined any types in Actions, we can safely process
  1393.      the implicit types and get our type.  */
  1394.  
  1395.       gnu_result_type = elaborate_node_types (gnat_node);
  1396.  
  1397.       /* If our result type is an unconstrained array, we must actually
  1398.      make the result of the expression be the fat pointer and
  1399.      dereference it outside of the RTL_EXPR that will get
  1400.      created.  This is because we will be relying on the fact
  1401.      that the UNCONSTRAINED_ARRAY_REF will eventually be removed,
  1402.      but it would otherwise be inside the RTL_EXPR.  */
  1403.       gnu_expr = gnat_to_gnu (Expression (gnat_node));
  1404.  
  1405.       if (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE)
  1406.     gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
  1407.  
  1408.       if (! global_bindings_p ())
  1409.     {
  1410.       expand_expr_stmt (gnu_expr);
  1411.       gnu_result = expand_end_stmt_expr (gnu_result);
  1412.       if (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE)
  1413.         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
  1414.     }
  1415.       else
  1416.     gnu_result = gnu_expr;
  1417.  
  1418.       break;
  1419.  
  1420.     /***************************/
  1421.     /* Chapter 5: Statements:  */
  1422.     /***************************/
  1423.  
  1424.     case N_Label:
  1425.       expand_label (gnat_to_gnu (Identifier (gnat_node)));
  1426.       process_implicit_types (gnat_node);
  1427.       break;
  1428.  
  1429.     case N_Null_Statement:
  1430.       process_implicit_types (gnat_node);
  1431.       break;
  1432.  
  1433.     case N_Assignment_Statement:
  1434.       {
  1435.     /* Get the LHS and RHS of the statement and convert any
  1436.        reference to an unconstrained array into a reference to
  1437.        the underlying array.  */
  1438.     tree gnu_lhs
  1439.       = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
  1440.     tree gnu_rhs
  1441.       = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
  1442.  
  1443.     /* If range check is needed, emit code to generate it */
  1444.     if (Do_Range_Check (Expression (gnat_node)))
  1445.       gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
  1446.  
  1447.     set_lineno (gnat_node, 1);
  1448.     expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
  1449.                        gnu_lhs, gnu_rhs));
  1450.  
  1451.     process_implicit_types (gnat_node);
  1452.       }
  1453.       break;
  1454.  
  1455.     case N_If_Statement:
  1456.       /* Start an IF statement giving the condition.  */
  1457.       gnu_expr = gnat_to_gnu (Condition (gnat_node));
  1458.       set_lineno (gnat_node, 1);
  1459.       expand_start_cond (gnu_expr, 0);
  1460.  
  1461.       push_momentary ();
  1462.  
  1463.       /* Generate code for the statements to be executed if the condition
  1464.      is true.  */
  1465.  
  1466.       for (gnat_temp = First (Then_Statements (gnat_node));
  1467.        Present (gnat_temp);
  1468.        gnat_temp = Next (gnat_temp))
  1469.     {
  1470.       gnat_to_code (gnat_temp);
  1471.       clear_momentary();
  1472.     }
  1473.  
  1474.       /* Generate each of the "else if" parts.  */
  1475.       if (Present (Elsif_Parts (gnat_node)))
  1476.     {
  1477.       for (gnat_temp = First (Elsif_Parts (gnat_node));
  1478.            Present (gnat_temp);
  1479.            gnat_temp = Next (gnat_temp))
  1480.         {
  1481.           Node_Id gnat_statement;
  1482.  
  1483.           expand_start_else ();
  1484.  
  1485.           /* Set up the line numbers for each condition we test.  */
  1486.           set_lineno (Condition (gnat_temp), 1);
  1487.           expand_elseif (gnat_to_gnu (Condition (gnat_temp)));
  1488.  
  1489.           for (gnat_statement = First (Then_Statements (gnat_temp));
  1490.            Present (gnat_statement);
  1491.            gnat_statement = Next (gnat_statement))
  1492.         {
  1493.           gnat_to_code (gnat_statement);
  1494.           clear_momentary ();
  1495.         }
  1496.         }
  1497.     }
  1498.  
  1499.       /* Finally, handle any statements in the "else" part.  */
  1500.       if (Present (Else_Statements (gnat_node)))
  1501.     {
  1502.       expand_start_else ();
  1503.  
  1504.       for (gnat_temp = First (Else_Statements (gnat_node));
  1505.            Present (gnat_temp);
  1506.            gnat_temp = Next (gnat_temp))
  1507.         {
  1508.           gnat_to_code (gnat_temp);
  1509.           clear_momentary ();
  1510.         }
  1511.     }
  1512.  
  1513.       pop_momentary ();
  1514.       expand_end_cond ();
  1515.       process_implicit_types (gnat_node);
  1516.       break;
  1517.  
  1518.     case N_Case_Statement:
  1519.       {
  1520.     Node_Id gnat_when;
  1521.     Node_Id gnat_choice;
  1522.     tree gnu_label;
  1523.     Node_Id gnat_statement;
  1524.  
  1525.     gnu_expr = gnat_to_gnu (Expression (gnat_node));
  1526.     set_lineno (gnat_node, 1);
  1527.     expand_start_case (1, gnu_expr, TREE_TYPE (gnu_expr), "case");
  1528.  
  1529.     push_momentary();
  1530.  
  1531.     for (gnat_when = First (Alternatives (gnat_node));
  1532.          Present (gnat_when);
  1533.          gnat_when = Next (gnat_when))
  1534.       {
  1535.         /* First compile all the different case choices for the  current
  1536.            WHEN alternative.  */
  1537.  
  1538.         for (gnat_choice = First (Discrete_Choices (gnat_when));
  1539.          Present (gnat_choice); gnat_choice = Next (gnat_choice))
  1540.               {
  1541.              gnu_label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
  1542.  
  1543.         set_lineno (gnat_choice, 1);
  1544.         switch (Nkind (gnat_choice))
  1545.           {
  1546.           case N_Range:
  1547.             pushcase_range
  1548.               (gnat_to_gnu (Low_Bound (gnat_choice)),
  1549.                gnat_to_gnu (High_Bound (gnat_choice)),
  1550.                convert, gnu_label, NULL_PTR);
  1551.             break;
  1552.  
  1553.           case N_Subtype_Indication:
  1554.             process_implicit_types (gnat_choice);
  1555.             pushcase_range
  1556.               (gnat_to_gnu (Low_Bound
  1557.                 (Range_Expression (Constraint (gnat_choice)))),
  1558.                gnat_to_gnu (High_Bound
  1559.                 (Range_Expression (Constraint (gnat_choice)))),
  1560.                convert, gnu_label, NULL_PTR);
  1561.             break;
  1562.  
  1563.           case N_Identifier:
  1564.                   case N_Expanded_Name:
  1565.             /* This represents either a subtype range or a static value
  1566.                of some kind; Ekind says which.  If a static value,
  1567.                fall through to the next case.  */
  1568.             if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
  1569.               {
  1570.             tree type
  1571.               = gnat_to_gnu_type (Entity (gnat_choice));
  1572.  
  1573.             pushcase_range (fold (TYPE_MIN_VALUE (type)),
  1574.                     fold (TYPE_MAX_VALUE (type)),
  1575.                     convert, gnu_label, NULL_PTR);
  1576.             break;
  1577.               }
  1578.             /* ... fall through ... */
  1579.           case N_Character_Literal:
  1580.           case N_Integer_Literal:
  1581.             pushcase (gnat_to_gnu (gnat_choice), convert,
  1582.                   gnu_label, NULL_PTR);
  1583.             break;
  1584.  
  1585.           case N_Others_Choice:
  1586.             pushcase (NULL_TREE, convert, gnu_label, NULL_PTR);
  1587.             break;
  1588.  
  1589.           default:
  1590.             gigi_abort (316);
  1591.           }
  1592.           }
  1593.  
  1594.         /* After compiling the choices attached to the WHEN compile the
  1595.            body of statements that have to be executed, should the
  1596.            "WHEN ... =>" be taken.  */
  1597.         for (gnat_statement = First (Statements (gnat_when));
  1598.          Present (gnat_statement);
  1599.          gnat_statement = Next (gnat_statement))
  1600.           {
  1601.         gnat_to_code (gnat_statement);
  1602.         clear_momentary ();
  1603.           }
  1604.  
  1605.         /* Communicate to GCC that we are done with the current WHEN,
  1606.            i.e. insert a "break" statement.  */
  1607.         expand_exit_something ();
  1608.       }
  1609.  
  1610.     pop_momentary();
  1611.     expand_end_case (gnu_expr);
  1612.     process_implicit_types (gnat_node);
  1613.       }
  1614.       break;
  1615.  
  1616.     case N_Loop_Parameter_Specification:
  1617.       /* nothing special has to be done here, this node is only processed 
  1618.      because it contains Itypes */
  1619.       process_implicit_types (gnat_node);
  1620.       break;
  1621.  
  1622.     case N_Loop_Statement:
  1623.       {
  1624.     /* The loop variable in GCC form, if any. */
  1625.     tree gnu_loop_var = NULL_TREE;
  1626.     /* PREINCREMENT_EXPR or PREDECREMENT_EXPR.  */
  1627.     enum tree_code gnu_update;
  1628.     /* Used if this is a named loop for so EXIT can work.  */
  1629.     struct nesting *loop_id;
  1630.     /* Condition to continue loop tested at top of loop.  */
  1631.     tree gnu_top_condition = integer_one_node;
  1632.     /* Similar, but tested at bottom of loop.  */
  1633.     tree gnu_bottom_condition = integer_one_node;
  1634.     Node_Id gnat_statement;
  1635.     Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
  1636.     Node_Id gnat_top_condition = Empty;
  1637.     int enclosing_if_p = 0;
  1638.  
  1639.     /* The loop param spec node contains Itypes, therefore it must be 
  1640.        processed in the standard way.  */
  1641.  
  1642.     if (Present (gnat_iter_scheme) 
  1643.         && Present (Loop_Parameter_Specification  (gnat_iter_scheme)))
  1644.       gnat_to_code (Loop_Parameter_Specification  (gnat_iter_scheme));
  1645.  
  1646.     /* Set the condition that under which the loop should continue.
  1647.        For "LOOP .... END LOOP;" the condition is always true.  */
  1648.     if (No (gnat_iter_scheme))
  1649.       ;
  1650.     /* The case "WHILE condition LOOP ..... END LOOP;" */
  1651.     else if (Present (Condition (gnat_iter_scheme)))
  1652.       gnat_top_condition = Condition (gnat_iter_scheme);
  1653.         else
  1654.       {
  1655.         /* We have an iteration scheme.  */
  1656.         Node_Id gnat_loop_spec
  1657.           = Loop_Parameter_Specification (gnat_iter_scheme);
  1658.         Entity_Id gnat_loop_var = Defining_Identifier (gnat_loop_spec);
  1659.         Entity_Id gnat_type = Etype (gnat_loop_var);
  1660.         tree gnu_type = gnat_to_gnu_type (gnat_type);
  1661.         tree gnu_low = TYPE_MIN_VALUE (gnu_type);
  1662.         tree gnu_high = TYPE_MAX_VALUE (gnu_type);
  1663.         int reversep = Reverse_Present (gnat_loop_spec);
  1664.         tree gnu_first = reversep ? gnu_high : gnu_low;
  1665.         tree gnu_last = reversep ? gnu_low : gnu_high;
  1666.         enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
  1667.         tree gnu_base_type = get_base_type (gnu_type);
  1668.         tree gnu_limit
  1669.           = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
  1670.          : TYPE_MAX_VALUE (gnu_base_type));
  1671.  
  1672.         /* We know the loop variable will not overflow if GNU_LAST is
  1673.            a constant and is not equal to GNU_LIMIT.  If it might
  1674.            overflow, we have to move the limit test to the end of
  1675.            the loop.  In that case, we have to test for an
  1676.            empty loop outside the loop.  */
  1677.         if (TREE_CODE (gnu_last) != INTEGER_CST
  1678.         || TREE_CODE (gnu_limit) != INTEGER_CST
  1679.         || tree_int_cst_equal (gnu_last, gnu_limit))
  1680.           {
  1681.         gnu_expr = build_binary_op (LE_EXPR, integer_type_node,
  1682.                         gnu_low, gnu_high);
  1683.         set_lineno (gnat_loop_spec, 1);
  1684.         expand_start_cond (gnu_expr, 0);
  1685.         enclosing_if_p = 1;
  1686.           }
  1687.  
  1688.  
  1689.         /* Open a new nesting level that will surround the loop to declare
  1690.            the loop index variable.  */
  1691.         pushlevel (0);
  1692.         expand_start_bindings (0);
  1693.  
  1694.         /* Declare the loop index and set it to its initial value.  */
  1695.         gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
  1696.  
  1697.         /* Set either the top or bottom exit condition as
  1698.            appropriate depending on whether we know an overflow
  1699.            cannot occur or not. */
  1700.         if (enclosing_if_p)
  1701.           gnu_bottom_condition
  1702.         = build_binary_op (NE_EXPR, integer_type_node,
  1703.                    gnu_loop_var, gnu_last);
  1704.         else
  1705.           gnu_top_condition
  1706.         = build_binary_op (end_code, integer_type_node,
  1707.                    gnu_loop_var, gnu_last);
  1708.  
  1709.         gnu_update = reversep ? PREDECREMENT_EXPR : PREINCREMENT_EXPR;
  1710.       }
  1711.  
  1712.     set_lineno (gnat_node, 1);
  1713.     if (gnu_loop_var)
  1714.       loop_id = expand_start_loop_continue_elsewhere (1);
  1715.     else
  1716.       loop_id = expand_start_loop (1);
  1717.  
  1718.     /* If the loop was named, have the name point to this loop.  In this
  1719.        case, the association is not a ..._DECL node; in fact, it isn't
  1720.        a GCC tree node at all.  Since this name is referenced inside
  1721.        the loop, do it before we process the statements of the loop.  */
  1722.         if (Present (Identifier (gnat_node)))
  1723.       save_gnu_tree (Entity (Identifier (gnat_node)),
  1724.              (tree) loop_id, 1);
  1725.  
  1726.     set_lineno (gnat_node, 1);
  1727.  
  1728.     /* We must evaluate the condition after we've entered the
  1729.        loop so that any expression actions get done in the right
  1730.        place.  */
  1731.     if (Present (gnat_top_condition))
  1732.       gnu_top_condition = gnat_to_gnu (gnat_top_condition);
  1733.  
  1734.     expand_exit_loop_if_false (NULL_PTR, gnu_top_condition);
  1735.     push_momentary ();
  1736.  
  1737.     for (gnat_statement = First (Statements (gnat_node));
  1738.          Present (gnat_statement);
  1739.          gnat_statement = Next (gnat_statement))
  1740.       {
  1741.         gnat_to_code (gnat_statement);
  1742.         clear_momentary ();
  1743.       }
  1744.  
  1745.     pop_momentary ();
  1746.     set_lineno (gnat_node, 1);
  1747.     expand_exit_loop_if_false (NULL_PTR, gnu_bottom_condition);
  1748.  
  1749.     if (gnu_loop_var)
  1750.       {
  1751.         expand_loop_continue_here ();
  1752.         gnu_expr = build_binary_op (gnu_update, TREE_TYPE (gnu_loop_var),
  1753.                     gnu_loop_var,
  1754.                     convert (TREE_TYPE (gnu_loop_var),
  1755.                          integer_one_node));
  1756.         set_lineno (gnat_iter_scheme, 1);
  1757.         expand_expr_stmt (gnu_expr);
  1758.       }
  1759.  
  1760.     set_lineno (gnat_node, 1);
  1761.     expand_end_loop ();
  1762.  
  1763.     if (gnu_loop_var)
  1764.       {
  1765.         /* Close the nesting level that sourround the loop that was used to
  1766.            declare the loop index variable.   */
  1767.         set_lineno (gnat_node, 1);
  1768.         expand_end_bindings (getdecls (), 1, 0);
  1769.         poplevel (1, 1, 0);
  1770.       }
  1771.  
  1772.     if (enclosing_if_p)
  1773.       {
  1774.         set_lineno (gnat_node, 1);
  1775.         expand_end_cond ();
  1776.       }
  1777.       }
  1778.       process_implicit_types (gnat_node);
  1779.       break;
  1780.  
  1781.     case N_Block_Statement:
  1782.       pushlevel (0);
  1783.       expand_start_bindings (0);
  1784.       process_decls (Declarations (gnat_node), Empty, Empty);
  1785.       gnat_to_code (Handled_Statement_Sequence (gnat_node));
  1786.       expand_end_bindings (getdecls (), 1, 0);
  1787.       poplevel (kept_level_p (), 1, 0);
  1788.       process_implicit_types (gnat_node);
  1789.       break;
  1790.  
  1791.     case N_Exit_Statement:
  1792.       {
  1793.     /* Which loop to exit, NULL if the current loop.   */
  1794.     struct nesting *loop_id = NULL_PTR;
  1795.     /* The GCC version of the optional GNAT condition node attached to the
  1796.        exit statement. Exit the loop if this is false.  */
  1797.     tree gnu_cond = integer_zero_node;
  1798.  
  1799.     if (Present (Name (gnat_node)))
  1800.       loop_id
  1801.         = (struct nesting *) get_gnu_tree (Entity (Name (gnat_node)));
  1802.  
  1803.     if (Present (Condition (gnat_node)))
  1804.       gnu_cond
  1805.         = invert_truthvalue
  1806.           (truthvalue_conversion (gnat_to_gnu (Condition (gnat_node))));
  1807.  
  1808.     set_lineno (gnat_node, 1);
  1809.     expand_exit_loop_if_false (loop_id, gnu_cond);
  1810.     process_implicit_types (gnat_node);
  1811.       }
  1812.       break;
  1813.  
  1814.     case N_Return_Statement:
  1815.       {
  1816.     /* The gnu function type of the subprogram currently processed.  */
  1817.     tree gnu_subprog_type = TREE_TYPE (current_function_decl);
  1818.     /* The return value from the subprogram.  */
  1819.     tree gnu_ret_val = 0;
  1820.  
  1821.     /* If we are dealing with a "return;" from an Ada procedure with
  1822.        parameters passed by copy in copy out, we need to return a record
  1823.        containing the final values of these parameters.  If the list
  1824.        contains only one entry, return just that entry.
  1825.  
  1826.        For a full description of the copy in copy out parameter mechanism,
  1827.        see the part of the gnat_to_gnu_entity routine dealing with the
  1828.        translation of subprograms. */
  1829.     if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
  1830.       {
  1831.         if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
  1832.           gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
  1833.         else
  1834.           gnu_ret_val
  1835.         = build_constructor (TREE_TYPE (gnu_subprog_type),
  1836.                      TYPE_CI_CO_LIST (gnu_subprog_type));
  1837.       }
  1838.  
  1839.     /* If the Ada subprogram is a function, we just need to return the
  1840.        expression.   If the subprogram returns an unconstrained
  1841.        array, we have to allocate a new version of the result and
  1842.        return it.  If we return by reference, return a pointer.  */
  1843.  
  1844.     else if (Present (Expression (gnat_node)))
  1845.       {
  1846.         gnu_ret_val  = gnat_to_gnu (Expression (gnat_node));
  1847.  
  1848.         if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
  1849.           {
  1850.         gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
  1851.         gnu_ret_val
  1852.           = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
  1853.                      TREE_TYPE (gnu_subprog_type),
  1854.                      Procedure_To_Call (gnat_node),
  1855.                      Storage_Pool (gnat_node));
  1856.           }
  1857.         else if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
  1858.           gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
  1859.       }
  1860.  
  1861.     set_lineno (gnat_node, 1);
  1862.     if (gnu_ret_val)
  1863.       expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
  1864.                       DECL_RESULT (current_function_decl),
  1865.                       gnu_ret_val));
  1866.     else
  1867.       expand_null_return ();
  1868.  
  1869.     process_implicit_types (gnat_node);
  1870.       }
  1871.       break;
  1872.  
  1873.     case N_Goto_Statement:
  1874.       gnu_expr = gnat_to_gnu (Name (gnat_node));
  1875.       TREE_USED (gnu_expr) = 1;
  1876.       set_lineno (gnat_node, 1);
  1877.       expand_goto (gnu_expr);
  1878.       process_implicit_types (gnat_node);
  1879.       break;
  1880.  
  1881.     case N_Raise_Statement:
  1882.  
  1883.       /* Either re-raise, raise a normal exception, or raise an exception
  1884.      that doesn't involve deferring.  */
  1885.  
  1886.       set_lineno (gnat_node, 1);
  1887.  
  1888.       expand_expr_stmt
  1889.     (build_call_1_expr (No_Defer (gnat_node)
  1890.                 ? raise_nodefer_decl : raise_decl,
  1891.                 (Present (Name (gnat_node))
  1892.                  ? build_unary_op (ADDR_EXPR, NULL_TREE,
  1893.                            gnat_to_gnu (Name (gnat_node)))
  1894.                  : gnu_except_ptr_decl)));
  1895.  
  1896.       process_implicit_types (gnat_node);
  1897.       break;
  1898.  
  1899.     /****************************/
  1900.     /* Chapter 6: Subprograms:  */
  1901.     /****************************/
  1902.  
  1903.     case N_Subprogram_Declaration:
  1904.       gnat_to_code (Specification (gnat_node));
  1905.       process_implicit_types (gnat_node);
  1906.       break;
  1907.  
  1908.     case N_Abstract_Subprogram_Declaration:
  1909.       process_implicit_types (gnat_node);
  1910.       break;
  1911.  
  1912.     case N_Function_Specification:
  1913.     case N_Procedure_Specification:
  1914.  
  1915.       process_implicit_types (gnat_node);
  1916.  
  1917.       /* Consider this a "definition" even though we won't actually be
  1918.      making code for the subprogram here.  This is because if we
  1919.      see the spec and are actually generating code, we know the body
  1920.      must be in this same file.  */
  1921.       if (No (Freeze_Node (Defining_Unit_Name (gnat_node))))
  1922.     gnat_to_gnu_entity (Defining_Unit_Name (gnat_node), NULL_TREE, 1);
  1923.  
  1924.       break;
  1925.  
  1926.     case N_Defining_Program_Unit_Name:
  1927.       /* For a child unit identifier go up a level to get the
  1928.          specificaton.  We get this when we try to find the spec of
  1929.      a child unit package that is the compilation unit being compiled. */
  1930.       gnat_to_code (Parent (gnat_node));
  1931.       process_implicit_types (gnat_node);
  1932.       break;
  1933.  
  1934.     case N_Subprogram_Body:
  1935.       {
  1936.     /* Definining identifier of a parameter to the subprogram.  */
  1937.         Entity_Id gnat_param;
  1938.         /* The declared entity currently being processed in the declarative
  1939.        part of the subprogram body.  */
  1940.         Entity_Id gnat_entity;
  1941.     /* The defining identifier for the subprogram body. Note that if a
  1942.        specification has appeared before for this body, then the identifier
  1943.        occurring in that specification will also be a defining identifier
  1944.        and all the calls to this subprogram will point to that
  1945.        specification.  */
  1946.     Entity_Id gnat_subprog_id
  1947.       = (Present (Corresponding_Spec (gnat_node))
  1948.          ? Corresponding_Spec (gnat_node)
  1949.          : Defining_Unit_Name (Specification (gnat_node)));
  1950.  
  1951.     /* The FUNCTION_DECL node corresponding to the subprogram spec.   */
  1952.     tree gnu_subprog_decl;
  1953.     /* The FUNCTION_TYPE node corresponding to the subprogram spec.  */
  1954.     tree gnu_subprog_type;
  1955.     tree gnu_cico_list;
  1956.  
  1957.         /* If the subprogram is a child unit,  retrieve simple name */
  1958.         gnat_subprog_id
  1959.            = (Nkind (gnat_subprog_id) == N_Defining_Program_Unit_Name
  1960.              ? Defining_Identifier (gnat_subprog_id)
  1961.              : gnat_subprog_id);
  1962.  
  1963.     /* If this is a generic object, ignore it.  */
  1964.     if (Ekind (gnat_subprog_id) == E_Generic_Procedure
  1965.         || Ekind (gnat_subprog_id) == E_Generic_Function)
  1966.       break;
  1967.  
  1968.     gnu_subprog_decl = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
  1969.     gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
  1970.  
  1971.     /* Set the line number in the decl to correspond to that of
  1972.        the body so that the line number notes are written 
  1973.        correctly.  */
  1974.     set_lineno (gnat_node, 0);
  1975.     DECL_SOURCE_FILE (gnu_subprog_decl) = input_filename;
  1976.     DECL_SOURCE_LINE (gnu_subprog_decl) = lineno;
  1977.  
  1978.     begin_subprog_body (gnu_subprog_decl);
  1979.     set_lineno (gnat_node, 1);
  1980.  
  1981.     /* If an ABE check is needed, add one.  */
  1982.     if (present_gnu_tree (Parent (Parent (gnat_subprog_id))))
  1983.       {
  1984.         expand_start_cond
  1985.           (build_binary_op
  1986.            (EQ_EXPR, integer_type_node,
  1987.         get_gnu_tree (Parent (Parent (gnat_subprog_id))),
  1988.         integer_zero_node),
  1989.            0);
  1990.         expand_expr_stmt (build_call_0_expr (raise_program_error_decl));
  1991.         expand_end_cond ();
  1992.       }
  1993.  
  1994.     pushlevel (0);
  1995.       expand_start_bindings (0);
  1996.  
  1997.     /* See if there are any parameters for which we don't yet have
  1998.        GCC entities.  These must be for OUT parameters for which we
  1999.        will be making VAR_DECL nodes here.  Fill them in to
  2000.        TYPE_CI_CO_LIST, which must contain the empty entry as well.
  2001.        We can match up the entries because TYPE_CI_CO_LIST is in the
  2002.        order of the parameters.
  2003.  
  2004.        If we make any new nodes here, make sure that they are in
  2005.        the object that the function declaration's type is in because we
  2006.        will be using them in the context of the caller.  */
  2007.  
  2008.     push_obstacks (TYPE_OBSTACK (gnu_subprog_type),
  2009.                TYPE_OBSTACK (gnu_subprog_type));
  2010.  
  2011.     gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
  2012.     for (gnat_param = First_Formal (gnat_subprog_id);
  2013.          Present (gnat_param);
  2014.          gnat_param = Next_Formal (gnat_param))
  2015.       if (! present_gnu_tree (gnat_param))
  2016.         {
  2017.           /* Skip any entries that have been already filled in; they
  2018.          must correspond to IN OUT parameters.  */
  2019.         for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0;
  2020.          gnu_cico_list = TREE_CHAIN (gnu_cico_list))
  2021.           ;
  2022.  
  2023.         TREE_VALUE (gnu_cico_list)
  2024.           = gnat_to_gnu_entity (gnat_param, NULL_TREE, 1);
  2025.       }
  2026.  
  2027.     pop_obstacks ();
  2028.  
  2029.     process_decls (Declarations (gnat_node), Empty, Empty);
  2030.  
  2031.     /* Generate the code of the subprogram itself.  A return statement
  2032.        will be present and any OUT parameters will be handled there.  */
  2033.     gnat_to_code (Handled_Statement_Sequence (gnat_node));
  2034.  
  2035.     expand_end_bindings (getdecls (), 1, 0);
  2036.     poplevel (kept_level_p (), 1, 0);
  2037.     end_subprog_body ();
  2038.  
  2039.     /* Throw away any VAR_DECLs we made for OUT parameters; they must
  2040.        not be seen when we call this function and will be in
  2041.        unallocated memory anyway.  Also throw away DECL_RTL in
  2042.        any PARM_DECLs unless this function was saved for inline, in
  2043.        which case the DECL_RTLs are in preserved memory.  */
  2044.     for (gnat_param = First_Formal (gnat_subprog_id);
  2045.          Present (gnat_param);
  2046.          gnat_param = Next_Formal (gnat_param))
  2047.       {
  2048.         tree gnu_param = get_gnu_tree (gnat_param);
  2049.  
  2050.         if (TREE_CODE (gnu_param) == VAR_DECL)
  2051.           save_gnu_tree (gnat_param, NULL_TREE, 0);
  2052.         else if (TREE_CODE (gnu_param) == PARM_DECL
  2053.              && DECL_SAVED_INSNS (gnu_subprog_decl) == 0)
  2054.           DECL_RTL (gnu_param) = DECL_INCOMING_RTL (gnu_param) = 0;
  2055.       }
  2056.  
  2057.     /* Similarly, discard DECL_RTL of the return value.  */
  2058.     if (DECL_SAVED_INSNS (gnu_subprog_decl) == 0)
  2059.       DECL_RTL (DECL_RESULT (gnu_subprog_decl))
  2060.         = DECL_INCOMING_RTL (DECL_RESULT (gnu_subprog_decl)) = 0;
  2061.       }
  2062.       process_implicit_types (gnat_node);
  2063.       break;
  2064.  
  2065.     case N_Function_Call:
  2066.     case N_Procedure_Call_Statement:
  2067.       {
  2068.     /* The GCC node corresponding to the GNAT subprogram name.  This can
  2069.        either be a FUNCTION_DECL node if we are dealing with a standard
  2070.        subprogram call, or an indirect reference expression (an
  2071.        INDIRECT_REF node) pointing to a subprogram.  */
  2072.     tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
  2073.     /* The FUNCTION_TYPE node giving the GCC type of the subprogram.  */
  2074.     tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
  2075.     tree gnu_subprog_addr
  2076.       = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node);
  2077.     Entity_Id gnat_formal;
  2078.     Node_Id gnat_actual;
  2079.     tree gnu_actual_list = NULL_TREE;
  2080.     tree gnu_name_list = NULL_TREE;
  2081.     tree gnu_subprog_call;
  2082.  
  2083.     if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE)
  2084.       gigi_abort (317);
  2085.  
  2086.     /* The only way we can be making a call via an access type is
  2087.        if Name is an explicit dereference.  In that case, get the
  2088.        list of formal args from the type the access type is pointing
  2089.        to.  Otherwise, get the formals from entity being called.  */
  2090.     if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
  2091.       gnat_formal = First_Formal (Etype (Name (gnat_node)));
  2092.     else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
  2093.       /* Assume here that this must be 'Elab_Body or 'Elab_Spec.  */
  2094.       gnat_formal = 0;
  2095.     else
  2096.       gnat_formal = First_Formal (Entity (Name (gnat_node)));
  2097.  
  2098.     /* Create the list of the actual parameters as GCC expects it, namely
  2099.        a chain of TREE_LIST nodes in which the TREE_VALUE field of each
  2100.        node is a parameter-expression and the TREE_PURPOSE field is
  2101.        null.  Skip OUT parameters that are not passed by reference.  */
  2102.  
  2103.         for (gnat_actual = First_Actual (gnat_node);
  2104.              Present (gnat_actual);
  2105.              gnat_formal = Next_Formal (gnat_formal),
  2106.              gnat_actual = Next_Actual (gnat_actual))
  2107.       {
  2108.         tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
  2109.         Node_Id gnat_name
  2110.           = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
  2111.         ? Expression (gnat_actual) : gnat_actual);
  2112.         tree gnu_name = gnat_to_gnu (gnat_name);
  2113.         tree gnu_actual;
  2114.  
  2115.         /* If it's possible we may need to use this expression twice,
  2116.            make sure than any side-effects are handled via SAVE_EXPRs. 
  2117.            Likewise if we need to force side-effects before the call. 
  2118.            ??? This is more conservative than we need since we don't
  2119.            need to do this for pass-by-ref with no conversion.  */
  2120.         if (Ekind (gnat_formal) != E_In_Parameter)
  2121.           gnu_name = gnat_stabilize_reference (gnu_name);
  2122.  
  2123.         gnu_actual = gnu_name;
  2124.         if (Ekind (gnat_formal) != E_Out_Parameter
  2125.         && Nkind (gnat_actual) != N_Unchecked_Type_Conversion
  2126.         && Do_Range_Check (gnat_actual))
  2127.           gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
  2128.  
  2129.         /* Do any needed conversions.  We need only check for
  2130.            unchecked conversion since normal conversions will be handled
  2131.            by just converting to the formal type.  */
  2132.         if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
  2133.           gnu_actual
  2134.         = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
  2135.                      gnu_actual);
  2136.  
  2137.         gnu_actual = convert (gnu_formal_type, gnu_actual);
  2138.  
  2139.         /* If we have not saved a GCC object for the formal, it means
  2140.            it is an OUT parameter not passed by reference.  Otherwise,
  2141.            look at the PARM_DECL to see if it is passed by reference. */
  2142.         if (present_gnu_tree (gnat_formal)
  2143.         && DECL_BY_REF_P (get_gnu_tree (gnat_formal)))
  2144.           {
  2145.         /* The symmetry of the paths to the type of an entity is
  2146.            broken here since arguments don't know that they will
  2147.            be passed by ref. */
  2148.         gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
  2149.         gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type,
  2150.                          gnu_actual);
  2151.           }
  2152.         else if (present_gnu_tree (gnat_formal)
  2153.              && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)))
  2154.           {
  2155.         gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
  2156.         gnu_actual = maybe_implicit_deref (gnu_actual);
  2157.         gnu_actual = maybe_unconstrained_array (gnu_actual);
  2158.  
  2159.         /* Take the address of the object and convert to the
  2160.            proper pointer type.  We'd like to actually compute
  2161.            the address of the beginning of the array using 
  2162.            an ADDR_EXPR of an ARRAY_REF, but there's a possibility
  2163.            that the ARRAY_REF might return a constant and we'd
  2164.            be getting the wrong address.  Neither approach is
  2165.            exactly correct, but this is the most likely to work
  2166.            in all cases.  */
  2167.         gnu_actual = convert (gnu_formal_type,
  2168.                       build_unary_op (ADDR_EXPR, NULL_TREE,
  2169.                               gnu_actual));
  2170.           }
  2171.  
  2172.         else
  2173.           {
  2174.         if (Ekind (gnat_formal) != E_In_Parameter)
  2175.           gnu_name_list
  2176.             = chainon (gnu_name_list,
  2177.                    build_tree_list (NULL_TREE, gnu_name));
  2178.  
  2179.         if (! present_gnu_tree (gnat_formal)
  2180.             || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL)
  2181.           continue;
  2182.           }
  2183.  
  2184.         gnu_actual_list
  2185.           = chainon (gnu_actual_list,
  2186.              build_tree_list (NULL_TREE, gnu_actual));
  2187.       }
  2188.  
  2189.     gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
  2190.                   gnu_subprog_addr, gnu_actual_list,
  2191.                   NULL_TREE);
  2192.     TREE_SIDE_EFFECTS (gnu_subprog_call) = 1;
  2193.  
  2194.     /* If it is a function call, the result is the call expression.  */
  2195.     if (Nkind (gnat_node) == N_Function_Call)
  2196.       {
  2197.         gnu_result = gnu_subprog_call;
  2198.  
  2199.         /* If the function returns an unconstrained array or by reference,
  2200.            we have to de-dereference the pointer.  */
  2201.         if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
  2202.         || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
  2203.           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
  2204.                        gnu_result);
  2205.  
  2206.         gnu_result_type = elaborate_node_types (gnat_node);
  2207.         break;
  2208.       }
  2209.  
  2210.     /* If this is the case where the GNAT tree contains a procedure call
  2211.        but the Ada procedure has copy in copy out parameters, the special
  2212.        parameter passing mechanism must be used.  */
  2213.     else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
  2214.       {
  2215.         /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
  2216.            in copy out parameters.  */
  2217.         tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
  2218.         int length = list_length (scalar_return_list);
  2219.  
  2220.         if (length > 1)
  2221.           {
  2222.         tree gnu_name;
  2223.  
  2224.         gnu_subprog_call = make_save_expr (gnu_subprog_call);
  2225.  
  2226.         /* If any of the names had side-effects, ensure they are
  2227.            all evaluated before the call.  */
  2228.         for (gnu_name = gnu_name_list; gnu_name;
  2229.              gnu_name = TREE_CHAIN (gnu_name))
  2230.           if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
  2231.             gnu_subprog_call
  2232.               = build (COMPOUND_EXPR, TREE_TYPE (gnu_subprog_call),
  2233.                    TREE_VALUE (gnu_name), gnu_subprog_call);
  2234.           }
  2235.  
  2236.         if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
  2237.           gnat_formal = First_Formal (Etype (Name (gnat_node)));
  2238.         else
  2239.           gnat_formal = First_Formal (Entity (Name (gnat_node)));
  2240.  
  2241.         for (gnat_actual = First_Actual (gnat_node);
  2242.          Present (gnat_actual);
  2243.          gnat_formal = Next_Formal (gnat_formal),
  2244.          gnat_actual = Next_Actual (gnat_actual))
  2245.           /* If we are dealing with a copy in copy out parameter, we must
  2246.          retrieve its value from the record returned in the function
  2247.          call.  */
  2248.           if (!pass_by_ref (gnat_to_gnu_type (Etype (gnat_formal)))
  2249.           && Ekind (gnat_formal) != E_In_Parameter)
  2250.         {
  2251.           /* Get the value to assign to this OUT or IN OUT
  2252.              parameter.  It is either the result of the function if
  2253.              there is only a single such parameter or the appropriate
  2254.              field from the record returned.  */
  2255.           tree gnu_result
  2256.             = length == 1 ? gnu_subprog_call
  2257.               : build_component_ref
  2258.             (gnu_subprog_call, NULL_TREE,
  2259.              TREE_PURPOSE (scalar_return_list));
  2260.           int unchecked_conversion
  2261.             = Nkind (gnat_actual) == N_Unchecked_Type_Conversion;
  2262.           /* If the actual is a conversion, get the inner expression,
  2263.              which will be the real destination, and convert the
  2264.              result to the type of the actual parameter.  */
  2265.           tree gnu_actual = TREE_VALUE (gnu_name_list);
  2266.  
  2267.                   /* If there is a type conversion we must check that the
  2268.                      returned value is within the variables constraints
  2269.                      before the conversion */
  2270.           if (Nkind (gnat_actual) == N_Type_Conversion
  2271.                       && Do_Range_Check (Expression (gnat_actual)))
  2272.                     gnu_result 
  2273.                       = emit_range_check (gnu_result,
  2274.                                           Etype (Expression (gnat_actual)));
  2275.  
  2276.           if (! unchecked_conversion && Do_Range_Check (gnat_actual))
  2277.             gnu_result = emit_range_check (gnu_result,
  2278.                            Etype (gnat_actual));
  2279.  
  2280.           if (unchecked_conversion)
  2281.             gnu_result
  2282.               = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result);
  2283.           else
  2284.             gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
  2285.  
  2286.           set_lineno (gnat_node, 1);
  2287.           expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
  2288.                              gnu_actual, gnu_result));
  2289.           scalar_return_list = TREE_CHAIN (scalar_return_list);
  2290.           gnu_name_list = TREE_CHAIN (gnu_name_list);
  2291.         }
  2292.  
  2293.         process_implicit_types (gnat_node);
  2294.         break;
  2295.       }
  2296.  
  2297.     set_lineno (gnat_node, 1);
  2298.     expand_expr_stmt (gnu_subprog_call);
  2299.     process_implicit_types (gnat_node);
  2300.       }
  2301.       break;
  2302.  
  2303.     /*************************/
  2304.     /* Chapter 7: Packages:  */
  2305.     /*************************/
  2306.  
  2307.     case N_Package_Declaration:
  2308.       /* The only time we actually see this node is if it is not the top-level
  2309.      unit.  So just expand the specification.  */
  2310.       gnat_to_code (Specification (gnat_node));
  2311.       process_implicit_types (gnat_node);
  2312.       break;
  2313.  
  2314.     case N_Package_Specification:
  2315.  
  2316.       process_decls (Visible_Declarations (gnat_node),
  2317.              Private_Declarations (gnat_node), Empty);
  2318.       process_implicit_types (gnat_node);
  2319.       break;
  2320.  
  2321.     case N_Package_Body:
  2322.  
  2323.       /* If this is the body of a generic package - do nothing */
  2324.       if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
  2325.     break;
  2326.  
  2327.       /* The only time we get here is if we are not processing this
  2328.      package body at the top level.  So just process all declarations and
  2329.      statements.  Package declarations have the same persistence as those
  2330.      in the containing object, so don't push a binding level here.
  2331.  
  2332.      ??? This means that declarations and statements will be intermixed,
  2333.      which might be trouble when we deal with cleanups, but worry about
  2334.      it then.  */
  2335.       process_decls (Declarations (gnat_node), Empty, Empty);
  2336.  
  2337.       /* If we are at the top level, record that we must generate code for
  2338.      any statements that actually belong in the body.  Otherwise,e
  2339.      generate code now.  */
  2340.       if (Present (Handled_Statement_Sequence (gnat_node)))
  2341.     {
  2342.       if (global_bindings_p ())
  2343.         add_pending_elaborations
  2344.           (NULL_TREE,
  2345.            make_transform_expr (Handled_Statement_Sequence (gnat_node),
  2346.                     void_type_node));
  2347.       else
  2348.         gnat_to_code (Handled_Statement_Sequence (gnat_node));
  2349.     }
  2350.       process_implicit_types (gnat_node);
  2351.       break;
  2352.  
  2353.     /*********************************/
  2354.     /* Chapter 8: Visibility Rules:  */
  2355.     /*********************************/
  2356.  
  2357.     case N_Use_Package_Clause:
  2358.     case N_Use_Type_Clause:
  2359.       /* Nothing to do here - but these may appear in list of declarations */
  2360.       process_implicit_types (gnat_node);
  2361.       break;
  2362.  
  2363.     /***********************/
  2364.     /* Chapter 9: Tasks:   */
  2365.     /***********************/
  2366.  
  2367.     case N_Protected_Type_Declaration:
  2368.       process_implicit_types (gnat_node);
  2369.       break;
  2370.  
  2371.     case N_Single_Task_Declaration:
  2372.       gnat_to_gnu_entity (Defining_Identifier (gnat_node), NULL_TREE, 1);
  2373.       process_implicit_types (gnat_node);
  2374.       break;
  2375.  
  2376.     /***********************************************************/
  2377.     /* Chapter 10: Program Structure and Compilation Issues:   */
  2378.     /***********************************************************/
  2379.  
  2380.     case N_Compilation_Unit:
  2381.       /* If we have a package body, process and make an elaboration
  2382.      routine for the spec and then do the same for the body.  */
  2383.       if (Nkind (Unit (gnat_node)) == N_Package_Body)
  2384.     {
  2385.       gnat_to_code (Parent (Corresponding_Spec (Unit (gnat_node))));
  2386.  
  2387.       Set_Has_No_Elab_Code
  2388.         (Library_Unit (gnat_node),
  2389.          build_package_elab (Corresponding_Spec (Unit (gnat_node)), 0,
  2390.                  get_pending_elaborations (), 0));
  2391.  
  2392.       process_inlined_subprograms (gnat_node);
  2393.       process_decls (Declarations (Unit (gnat_node)), Empty, Empty);
  2394.       Set_Has_No_Elab_Code
  2395.         (gnat_node,
  2396.          build_package_elab (Defining_Unit_Name (Unit (gnat_node)), 1,
  2397.                  get_pending_elaborations (),
  2398.                  Handled_Statement_Sequence (Unit (gnat_node))));
  2399.     }
  2400.  
  2401.       /* If we have a package spec, handle the declarations and
  2402.      elaboration function for it.  We can't do anything with any
  2403.      inlined functions here due to order of elaboration concerns.  */
  2404.       else if (Nkind (Unit (gnat_node)) == N_Package_Declaration)
  2405.     {
  2406.       Entity_Id gnat_spec = Specification (Unit (gnat_node));
  2407.  
  2408.       gnat_to_code (gnat_spec);
  2409.  
  2410.       Set_Has_No_Elab_Code
  2411.         (gnat_node,
  2412.          build_package_elab (Defining_Unit_Name (gnat_spec), 0,
  2413.                  get_pending_elaborations (), 0));
  2414.     }
  2415.  
  2416.       /* For library level subprogram bodies create elaboration functions for
  2417.      spec and body, if needed.  */
  2418.       else if (Nkind (Unit (gnat_node)) == N_Subprogram_Body)
  2419.     {
  2420.       process_inlined_subprograms (gnat_node);
  2421.  
  2422.       Set_Has_No_Elab_Code
  2423.         (Library_Unit (gnat_node),
  2424.          build_subprogram_elab (Defining_Unit_Name
  2425.                     (Specification (Unit (gnat_node))),
  2426.                     0));
  2427.       Set_Has_No_Elab_Code
  2428.         (gnat_node,
  2429.          build_subprogram_elab (Defining_Unit_Name
  2430.                     (Specification (Unit (gnat_node))),
  2431.                     1));
  2432.       gnat_to_code (Unit (gnat_node));
  2433.     }
  2434.  
  2435.       /* Otherwise, process whatever unit we are called with.  */
  2436.       else
  2437.     {
  2438.       process_inlined_subprograms (gnat_node);
  2439.       gnat_to_code (Unit (gnat_node));
  2440.     }
  2441.  
  2442.       /* Process any pragmas following the unit.  */
  2443.       if (Present (Following_Pragmas (gnat_node)))
  2444.     for (gnat_temp = First (Following_Pragmas (gnat_node));
  2445.          gnat_temp; gnat_temp = Next (gnat_temp))
  2446.       gnat_to_code (gnat_temp);
  2447.  
  2448.       break;
  2449.  
  2450.     case N_Subprogram_Body_Stub:
  2451.     case N_Package_Body_Stub:
  2452.     case N_Protected_Body_Stub:
  2453.     case N_Task_Body_Stub:
  2454.       /* Simply process whatever unit is being inserted.  */
  2455.       gnat_to_code (Library_Unit (gnat_node));
  2456.       process_implicit_types (gnat_node);
  2457.       break;
  2458.  
  2459.     case N_Subunit:
  2460.       gnat_to_code (Proper_Body (gnat_node));
  2461.       process_implicit_types (gnat_node);
  2462.       break;
  2463.  
  2464.     /***************************/
  2465.     /* Chapter 11: Exceptions: */
  2466.     /***************************/
  2467.  
  2468.     case N_Handled_Sequence_Of_Statements:
  2469.       /* If there are exeption handlers, start a new binding level that
  2470.      we can exit (since each exception handler will do so).  Then
  2471.      declare a variable to save the old __gnat_jmpbuf value and a
  2472.      variable for our jmpbuf.  Call setjmp and handle each of the
  2473.      possible exceptions if it returns one.
  2474.  
  2475.      ??? We have a short-term kludge where we allow an N_Identifier
  2476.      of a procedure to be in Identifier.  In that case, exception
  2477.      handlers aren't allowed.  We make an exception handler that
  2478.      calls the specified function and does a re-raise.  We also
  2479.      put a call to that function as a cleanup action for that block.  */
  2480.  
  2481.       if (Present (Exception_Handlers (gnat_node))
  2482.       || Present (Identifier (gnat_node)))
  2483.     {
  2484.       tree gnu_jmpsave_decl;
  2485.       tree gnu_jmpbuf_decl;
  2486.       tree gnu_old_except_ptr_decl = gnu_except_ptr_decl;
  2487.       tree gnu_cleanup_call = 0;
  2488.       tree gnu_cleanup_decl;
  2489.       int moment = suspend_momentary ();
  2490.  
  2491.       pushlevel (0);
  2492.       expand_start_bindings (1);
  2493.  
  2494.       gnu_jmpsave_decl
  2495.         = create_var_decl ("jmpbuf_save", NULL_PTR,
  2496.                    jmpbuf_ptr_type,
  2497.                    build_call_0_expr (get_jmpbuf_decl), NULL_TREE,
  2498.                    0, 0, 0, 0, 0);
  2499.  
  2500.       gnu_jmpbuf_decl = create_var_decl ("jmp_buf", NULL_PTR, jmpbuf_type,
  2501.                          NULL_TREE, NULL_TREE, 0,
  2502.                          0, 0, 0, 0);
  2503.  
  2504.       /* See if we are to call a function when exiting this block.  */
  2505.       if (Present (Identifier (gnat_node)))
  2506.         {
  2507.           gnu_cleanup_call
  2508.         = build_call_0_expr (gnat_to_gnu (Identifier (gnat_node)));
  2509.  
  2510.           gnu_cleanup_decl
  2511.         = create_var_decl ("cleanup", NULL_PTR, integer_type_node,
  2512.                    NULL_TREE, NULL_TREE, 0, 0, 0, 0, 0);
  2513.  
  2514.           expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
  2515.         }
  2516.  
  2517.       /* When we exit this block, restore the saved value.  */
  2518.       expand_decl_cleanup (gnu_jmpsave_decl,
  2519.                    build_call_1_expr (set_jmpbuf_decl,
  2520.                           gnu_jmpsave_decl));
  2521.  
  2522.       resume_momentary (moment);
  2523.  
  2524.       /* Call setjmp and handle exceptions if it returns one.  */
  2525.       set_lineno (gnat_node, 1);
  2526.       expand_start_cond
  2527.         (build_call_1_expr (setjmp_decl,
  2528.                 build_unary_op (ADDR_EXPR, NULL_TREE,
  2529.                         gnu_jmpbuf_decl)),
  2530.          0);
  2531.  
  2532.       /* Restore our incoming longjmp value before we do anything.  */
  2533.       expand_expr_stmt (build_call_1_expr (set_jmpbuf_decl,
  2534.                            gnu_jmpsave_decl));
  2535.  
  2536.       /* If we have a cleanup to do, emit it now.  */
  2537.       if (gnu_cleanup_call)
  2538.         expand_expr_stmt (gnu_cleanup_call);
  2539.  
  2540.       pushlevel (0);
  2541.       expand_start_bindings (0);
  2542.  
  2543.       gnu_except_ptr_decl
  2544.         = create_var_decl ("except_ptr", NULL_PTR,
  2545.                    build_pointer_type (except_type_node),
  2546.                    build_call_0_expr (get_excptr_decl),
  2547.                    NULL_TREE, 0, 0, 0, 0, 0);
  2548.  
  2549.       /* Generate code for each exception handler.  The code at
  2550.          N_Exception_Handler below does the real work.  */
  2551.       if (Present (Exception_Handlers (gnat_node)))
  2552.         for (gnat_temp = First (Exception_Handlers (gnat_node));
  2553.          Present (gnat_temp); gnat_temp = Next (gnat_temp))
  2554.           gnat_to_code (gnat_temp);
  2555.  
  2556.       /* If none of the exception handlers did anything, re-raise.  */
  2557.       set_lineno (gnat_node, 1);
  2558.       expand_expr_stmt (build_call_1_expr (raise_decl,
  2559.                            gnu_except_ptr_decl));
  2560.  
  2561.       gnu_except_ptr_decl = gnu_old_except_ptr_decl;
  2562.       expand_end_bindings (getdecls (), 1, 0);
  2563.       poplevel (kept_level_p (), 1, 0);
  2564.  
  2565.       /* End the "if" on setjmp.  Note that we have arranged things so
  2566.          control never returns here.  */
  2567.       expand_end_cond ();
  2568.  
  2569.       /* This is now immediately before the body proper.  Set
  2570.          our jmp_buf as the current buffer.  */
  2571.       expand_expr_stmt
  2572.         (build_call_1_expr (set_jmpbuf_decl,
  2573.                 build_unary_op (ADDR_EXPR, NULL_TREE,
  2574.                         gnu_jmpbuf_decl)));
  2575.     }
  2576.  
  2577.       /* Generate code and declarations for the prefix of this block, 
  2578.      if any.  */
  2579.       if (Present (First_Real_Statement (gnat_node)))
  2580.     process_decls (Statements (gnat_node), Empty,
  2581.                First_Real_Statement (gnat_node));
  2582.  
  2583.       /* Generate code for each statement in the block.  */
  2584.       push_momentary ();
  2585.       for (gnat_temp = (Present (First_Real_Statement (gnat_node))
  2586.             ? First_Real_Statement (gnat_node)
  2587.             : First (Statements (gnat_node)));
  2588.        Present (gnat_temp); gnat_temp = Next (gnat_temp))
  2589.     {
  2590.       gnat_to_code (gnat_temp);
  2591.       clear_momentary ();
  2592.     }
  2593.  
  2594.       pop_momentary ();
  2595.  
  2596.       /* If we have handlers, close the block we made.  */
  2597.       if (Present (Identifier (gnat_node))
  2598.       || Present (Exception_Handlers (gnat_node)))
  2599.     {
  2600.       expand_end_bindings (getdecls (), 1, 0);
  2601.       poplevel (kept_level_p (), 1, 0);
  2602.     }
  2603.  
  2604.       process_implicit_types (gnat_node);
  2605.       break;
  2606.  
  2607.     case N_Exception_Handler:
  2608.       {
  2609.     /* Unless this is "Others", make an "if" statement to select
  2610.        the proper exceptions.  For "Others", exclude exceptions whose
  2611.        data block is nonzero; this is used for Abort.  */
  2612.     tree gnu_choice = integer_zero_node;
  2613.  
  2614.     for (gnat_temp = First (Exception_Choices (gnat_node));
  2615.          gnat_temp; gnat_temp = Next (gnat_temp))
  2616.       {
  2617.         tree this_choice;
  2618.  
  2619.         if (Nkind (gnat_temp) == N_Others_Choice)
  2620.           this_choice
  2621.         = build_binary_op (EQ_EXPR, integer_type_node,
  2622.                    build_unary_op (INDIRECT_REF, NULL_TREE,
  2623.                            gnu_except_ptr_decl),
  2624.                    convert (char_type_node,
  2625.                         integer_zero_node));
  2626.  
  2627.         else if (Nkind (gnat_temp) == N_Identifier
  2628.                      || Nkind (gnat_temp) == N_Expanded_Name)
  2629.           this_choice
  2630.         = build_binary_op (EQ_EXPR, integer_type_node,
  2631.                    gnu_except_ptr_decl,
  2632.                    build_unary_op (ADDR_EXPR, NULL_TREE,
  2633.                            gnat_to_gnu (gnat_temp)));
  2634.  
  2635.         else
  2636.           gigi_abort (318);
  2637.  
  2638.         gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
  2639.                       gnu_choice, this_choice);
  2640.       }
  2641.  
  2642.     set_lineno (gnat_node, 1);
  2643.     expand_start_cond (gnu_choice, 0);
  2644.  
  2645.     /* Generate code for the exception handler.  If we have a
  2646.        Choice_Parameter, make a block to put its definition in,
  2647.        define it, and initialize to the exception occurrence. */
  2648.     if (Present (Choice_Parameter (gnat_node)))
  2649.       {
  2650.         pushlevel (0);
  2651.         expand_start_bindings (0);
  2652.         gnat_to_gnu_entity (Choice_Parameter (gnat_node),
  2653.                 gnu_except_ptr_decl, 1);
  2654.       }
  2655.  
  2656.     push_momentary ();
  2657.     for (gnat_temp = First (Statements (gnat_node));
  2658.          gnat_temp; gnat_temp = Next (gnat_temp))
  2659.       {
  2660.         gnat_to_code (gnat_temp);
  2661.         clear_momentary ();
  2662.       }
  2663.  
  2664.     pop_momentary ();
  2665.  
  2666.     if (Present (Choice_Parameter (gnat_node)))
  2667.       {
  2668.         expand_end_bindings (getdecls (), 1, 0);
  2669.         poplevel (1, 1, 0);
  2670.       }
  2671.  
  2672.     /* At the end of the handler, exit the block.  We made this block
  2673.        in N_Handled_Sequence_Of_Statements.  */
  2674.     expand_exit_something ();
  2675.     expand_end_cond ();
  2676.     process_implicit_types (gnat_node);
  2677.       }
  2678.       break;
  2679.  
  2680.     /*******************************/
  2681.     /* Chapter 12: Generic Units:  */
  2682.     /*******************************/
  2683.  
  2684.     case N_Generic_Function_Renaming_Declaration:
  2685.     case N_Generic_Package_Renaming_Declaration:
  2686.     case N_Generic_Procedure_Renaming_Declaration:
  2687.     case N_Generic_Package_Declaration:
  2688.     case N_Generic_Subprogram_Declaration:
  2689.     case N_Package_Instantiation:
  2690.     case N_Procedure_Instantiation:
  2691.     case N_Function_Instantiation:
  2692.       /* These nodes can appear on a declaration list but there is nothing to
  2693.      to be done with them.  */
  2694.       process_implicit_types (gnat_node);
  2695.       break;
  2696.  
  2697.  
  2698.     /***************************************************/
  2699.     /* Chapter 13: Representation Clauses and           */
  2700.     /*             Implementation-Dependent Features:  */
  2701.     /***************************************************/
  2702.  
  2703.     case N_Attribute_Definition_Clause:
  2704.  
  2705.       /* The only one we need deal with is for 'Address.  For the others, SEM
  2706.      puts the information elsewhere.  We need only deal with 'Address
  2707.      if the object has a Freeze_Node (which it never will currently).  */
  2708.       if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
  2709.       || No (Freeze_Node (Entity (Name (gnat_node)))))
  2710.     break;
  2711.  
  2712.       /* Get the value to use as the address and save it as the
  2713.      equivalent for GNAT_TEMP.  When the object is frozen,
  2714.      gnat_to_gnu_entity will do the right thing. */
  2715.       gnu_expr = gnat_to_gnu (Expression (gnat_node));
  2716.       save_gnu_tree (Entity (Name (gnat_node)), gnu_expr, 1);
  2717.       process_implicit_types (gnat_node);
  2718.       break;
  2719.  
  2720.     case N_Enumeration_Representation_Clause:
  2721.     case N_Record_Representation_Clause:
  2722.     case N_At_Clause:
  2723.       /* We do nothing with these.  SEM puts the information elsewhere.  */
  2724.       break;
  2725.  
  2726.     /***************************************************/
  2727.     /* Added Nodes                                   */
  2728.     /***************************************************/
  2729.  
  2730.     case N_Freeze_Entity:
  2731.       {
  2732.     Entity_Id gnat_entity = Entity (gnat_node);
  2733.     tree gnu_old;
  2734.     tree gnu_new;
  2735.     tree gnu_init
  2736.       = (Nkind (Parent (gnat_entity)) == N_Object_Declaration
  2737.          && present_gnu_tree (Parent (gnat_entity)))
  2738.         ? get_gnu_tree (Parent (gnat_entity)) : NULL_TREE;
  2739.  
  2740.     process_implicit_types (gnat_node);
  2741.  
  2742.     /* Check for old definition after the above call.  This Freeze_Node
  2743.        might be for one its Itypes.  */
  2744.      gnu_old
  2745.        = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
  2746.  
  2747.     /* If this entity has an Address representation clause,
  2748.        GNU_OLD is the address, so discard it here.  */
  2749.     if (Present (Address_Clause (gnat_entity)))
  2750.       gnu_old = 0;
  2751.  
  2752.     /* If we have a non-dummy type old tree, we have nothing to do.
  2753.        Unless this is the public view of a private type whose
  2754.        full view was not delayed, this node was never delayed
  2755.         as it should have been.  */
  2756.     if (gnu_old != 0
  2757.         && ! (TREE_CODE (gnu_old) == TYPE_DECL
  2758.           && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
  2759.       {
  2760.         if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
  2761.         && Present (Full_View (gnat_entity))
  2762.         && No (Freeze_Node (Full_View (gnat_entity))))
  2763.           break;
  2764.         else
  2765.           gigi_abort (320);
  2766.       }
  2767.  
  2768.     /* Reset the saved tree, if any, and elaborate the object or
  2769.        type for real.  If there is a full declaration, elaborate
  2770.        it and copy the type to GNAT_ENTITY.  */
  2771.     if (gnu_old != 0)
  2772.       {
  2773.         save_gnu_tree (gnat_entity, NULL_TREE, 0);
  2774.         if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
  2775.         && Present (Full_View (gnat_entity))
  2776.         && present_gnu_tree (Full_View (gnat_entity))
  2777.         && get_gnu_tree (Full_View (gnat_entity)) == gnu_old)
  2778.           save_gnu_tree (Full_View (gnat_entity), NULL_TREE, 0);
  2779.       }
  2780.  
  2781.     if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
  2782.         && Present (Full_View (gnat_entity)))
  2783.       {
  2784.         gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity),
  2785.                       NULL_TREE, 0);
  2786.         save_gnu_tree (gnat_entity, gnu_new, 0);
  2787.       }
  2788.     else
  2789.       gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
  2790.  
  2791.     /* If we've made any pointers to the old version of this type, we have
  2792.        to update them.  */
  2793.     if (gnu_old != 0)
  2794.       update_pointer_to (TREE_TYPE (gnu_old), TREE_TYPE (gnu_new));
  2795.  
  2796.     if (Present (Actions (gnat_node)))
  2797.       for (gnat_temp = First (Actions (gnat_node)); gnat_temp;
  2798.            gnat_temp = Next (gnat_temp))
  2799.         gnat_to_code (gnat_temp);
  2800.       }
  2801.  
  2802.  
  2803.       break;
  2804.  
  2805.     case N_Free_Statement:
  2806.       {
  2807.     tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
  2808.     tree gnu_obj_size;
  2809.     int align;
  2810.  
  2811.     /* If this is an unconstrained array, we know the object must
  2812.        have been allocated with the template in front of the object.
  2813.        So pass the template address, but get the total size.  */
  2814.     if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
  2815.       {
  2816.         tree gnu_ptr_template_field
  2817.           = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_ptr)));
  2818.         tree gnu_template_type
  2819.           = TREE_TYPE (TREE_TYPE (gnu_ptr_template_field));
  2820.         tree gnu_array_type
  2821.           = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_ptr))));
  2822.  
  2823.         gnu_obj_size = size_binop (PLUS_EXPR,
  2824.                        TYPE_SIZE (gnu_template_type),
  2825.                        TYPE_SIZE (gnu_array_type));
  2826.         align = MAX (TYPE_ALIGN (gnu_template_type),
  2827.              TYPE_ALIGN (gnu_array_type));
  2828.  
  2829.         gnu_ptr = build_component_ref (gnu_ptr,  NULL_TREE,
  2830.                        gnu_ptr_template_field);
  2831.       }
  2832.     else
  2833.       {
  2834.         tree gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
  2835.  
  2836.         gnu_obj_size = TYPE_SIZE (gnu_obj_type);
  2837.         align = TYPE_ALIGN (gnu_obj_type);
  2838.       }
  2839.  
  2840.     set_lineno (gnat_node, 1);
  2841.     expand_expr_stmt
  2842.       (build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
  2843.                      Procedure_To_Call (gnat_node),
  2844.                      Storage_Pool (gnat_node)));
  2845.  
  2846.     process_implicit_types (gnat_node);
  2847.       }
  2848.       break;
  2849.  
  2850.     case N_Raise_Constraint_Error:
  2851.       gnu_result = build_call_0_expr (raise_constraint_error_decl);
  2852.       gnu_result_type = elaborate_node_types (gnat_node);
  2853.       gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
  2854.       break;
  2855.  
  2856.     case N_Op_Concat:
  2857.     case N_Component_Association:
  2858.     case N_Task_Body:
  2859.     default:
  2860.       gigi_abort (321);
  2861.     }
  2862.  
  2863.   /* Now convert the result to the proper type.  If the type is void or if
  2864.      we have no result, return error_mark_node to show we have no result.
  2865.      If the type of the result is correct or if we have a label (which doesn't
  2866.      have any well-defined type), return our result.  Also don't do the
  2867.      conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
  2868.      since those are the cases where the front end may have the type wrong due
  2869.      to "instantiating" the unconstrained record with discriminant values
  2870.      or if this is a FIELD_DECL.   Otherwise, convert the result to the
  2871.      proper type.  */
  2872.  
  2873.   if (TREE_CODE (gnu_result) == LABEL_DECL
  2874.       || TREE_CODE (gnu_result) == FIELD_DECL
  2875.       || (TYPE_SIZE (gnu_result_type)
  2876.       && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
  2877.       && contains_placeholder_p (TYPE_SIZE (gnu_result_type))
  2878.       && ! (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
  2879.         && TYPE_COMPONENT_MAX_TYPE_P (TREE_TYPE (gnu_result)))))
  2880.     ;
  2881.   else if (gnu_result == error_mark_node
  2882.        || gnu_result_type == void_type_node)
  2883.     gnu_result =  error_mark_node;
  2884.   else if (gnu_result_type != TREE_TYPE (gnu_result))
  2885.     gnu_result = convert (gnu_result_type, gnu_result);
  2886.  
  2887.   /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT.  */
  2888.   while ((TREE_CODE (gnu_result) == NOP_EXPR
  2889.       || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
  2890.      && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
  2891.     gnu_result = TREE_OPERAND (gnu_result, 0);
  2892.  
  2893.   /* If our result has side-effects and is of an unconstrained type,
  2894.      make a SAVE_EXPR so that we can be sure it will only be referenced
  2895.      once.  */
  2896.   if (TREE_SIDE_EFFECTS (gnu_result)
  2897.       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
  2898.       || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
  2899.           && contains_placeholder_p (TYPE_SIZE (gnu_result_type)))))
  2900.     gnu_result = gnat_stabilize_reference (gnu_result);
  2901.  
  2902.   return gnu_result;
  2903. }
  2904.  
  2905. /* Process the list of inlined subprograms of GNAT_NODE, which is an
  2906.    N_Compilation_Unit.  */
  2907.  
  2908. static void
  2909. process_inlined_subprograms (gnat_node)
  2910.      Node_Id gnat_node;
  2911. {
  2912.   Entity_Id gnat_entity;
  2913.   Node_Id gnat_body;
  2914.  
  2915.   /* If we can inline, generate RTL for all the inlined subprograms.
  2916.      Define the entity first so we set DECL_EXTERNAL.  */
  2917.   if (optimize > 0 && ! flag_no_inline)
  2918.     for (gnat_entity = First_Inlined_Subprogram (gnat_node);
  2919.      Present (gnat_entity);
  2920.      gnat_entity = Next_Inlined_Subprogram (gnat_entity))
  2921.       {
  2922.     gnat_body = Parent (Parent (gnat_entity));
  2923.  
  2924.     if (Nkind (gnat_body) != N_Subprogram_Body)
  2925.       gnat_body = Parent (Parent (Corresponding_Body (gnat_body)));
  2926.  
  2927.     if (Present (gnat_body))
  2928.       {
  2929.         gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
  2930.         gnat_to_code (gnat_body);
  2931.       }
  2932.       }
  2933. }
  2934.  
  2935. /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
  2936.    We make two passes, one to elaborate anything other than bodies (but
  2937.    we declare a function if there was no spec).  The second pass
  2938.    elaborates the bodies.
  2939.  
  2940.    GNAT_END_LIST gives the element in the list past the end.  Normally,
  2941.    this is Empty, but can be First_Real_Statement for a
  2942.    Handled_Sequence_Of_Statements.
  2943.  
  2944.    We make a complete pass through both list, the make the second pass
  2945.    over both lists.  The lists usually correspond to the public and
  2946.    private parts of a package.  */
  2947.  
  2948. static void
  2949. process_decls (gnat_decls, gnat_decls2, gnat_end_list)
  2950.      List_Id gnat_decls, gnat_decls2;
  2951.      Node_Id gnat_end_list;
  2952. {
  2953.   List_Id gnat_decl_array[2];
  2954.   Node_Id gnat_decl;
  2955.   int i;
  2956.  
  2957.   gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
  2958.  
  2959.   for (i = 0; i <= 1; i++)
  2960.     if (Present (gnat_decl_array[i]))
  2961.       for (gnat_decl = First (gnat_decl_array[i]);
  2962.        gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
  2963.     {
  2964.       set_lineno (gnat_decl, 0);
  2965.  
  2966.       if (Nkind (gnat_decl) == N_Package_Body)
  2967.         record_code_position (gnat_decl);
  2968.       else if (Nkind (gnat_decl) == N_Subprogram_Declaration)
  2969.         {
  2970.           Entity_Id gnat_subprog
  2971.         = Defining_Unit_Name (Specification (gnat_decl));
  2972.  
  2973.           if (Ekind (gnat_subprog) != E_Generic_Procedure
  2974.           && Ekind (gnat_subprog) != E_Generic_Function
  2975.           && Comes_From_Source (gnat_subprog)
  2976.           && ! Suppress_Elaboration_Checks (gnat_subprog)
  2977.           && ! Is_Intrinsic_Subprogram (gnat_subprog)
  2978.           && ! Is_Imported (gnat_subprog))
  2979.         save_gnu_tree (gnat_decl,
  2980.                    create_var_decl
  2981.                  (create_concat_name (gnat_subprog, "ABE"),
  2982.                   NULL_PTR, integer_type_node,
  2983.                   integer_zero_node, NULL_TREE, 0, 0, 1,
  2984.                   0, 0),
  2985.                    1);
  2986.  
  2987.           gnat_to_code (gnat_decl);
  2988.         }
  2989.       else if (Nkind (gnat_decl) == N_Subprogram_Body
  2990.            || Nkind (gnat_decl) == N_Subprogram_Body_Stub)
  2991.         {
  2992.           Node_Id gnat_real_decl = gnat_decl;
  2993.  
  2994.           if (Nkind (gnat_real_decl) == N_Subprogram_Body_Stub)
  2995.         gnat_real_decl
  2996.           = Proper_Body (Unit (Library_Unit (gnat_real_decl)));
  2997.  
  2998.           if (No (Corresponding_Spec (gnat_real_decl)))
  2999.         {
  3000.           Node_Id gnat_subprog_id
  3001.             = Defining_Unit_Name (Specification (gnat_real_decl));
  3002.  
  3003.           if (Nkind (gnat_subprog_id) == N_Defining_Program_Unit_Name)
  3004.             gnat_subprog_id = Defining_Identifier (gnat_subprog_id);
  3005.  
  3006.           if (Ekind (gnat_subprog_id) != E_Generic_Procedure
  3007.               && Ekind (gnat_subprog_id) != E_Generic_Function)
  3008.             gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
  3009.         }
  3010.           else if (present_gnu_tree
  3011.                (Parent (Parent (Corresponding_Spec (gnat_real_decl)))))
  3012.         {
  3013.           tree gnu_abevar
  3014.             = get_gnu_tree
  3015.               (Parent (Parent (Corresponding_Spec (gnat_real_decl))));
  3016.  
  3017.           if (global_bindings_p ())
  3018.             add_pending_elaborations (gnu_abevar, integer_one_node);
  3019.           else
  3020.             expand_expr_stmt
  3021.               (build_binary_op (MODIFY_EXPR, integer_type_node,
  3022.                     gnu_abevar, integer_one_node));
  3023.         }
  3024.         }
  3025.       else
  3026.         gnat_to_code (gnat_decl);
  3027.     }
  3028.  
  3029.   for (i = 0; i <= 1; i++)
  3030.     if (Present (gnat_decl_array[i]))
  3031.       for (gnat_decl = First (gnat_decl_array[i]);
  3032.        gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
  3033.     {
  3034.       if (Nkind (gnat_decl) == N_Package_Body)
  3035.         insert_code_for (gnat_decl);
  3036.       else if (Nkind (gnat_decl) == N_Subprogram_Body
  3037.            || Nkind (gnat_decl) == N_Subprogram_Body_Stub)
  3038.         gnat_to_code (gnat_decl);
  3039.     }
  3040. }
  3041.  
  3042.  
  3043.  
  3044. /* Emits an access check. GNU_EXPR is the expression that needs to be
  3045.    checked against the NULL pointer. */
  3046.  
  3047. static tree
  3048. emit_access_check (gnu_expr)
  3049.      tree gnu_expr;
  3050. {
  3051.   tree gnu_type = TREE_TYPE (gnu_expr);
  3052.  
  3053.   /* This only makes sense if GNU_TYPE is a pointer of some sort.  */
  3054.   if (TREE_CODE (gnu_type) != POINTER_TYPE
  3055.       && ! TYPE_FAT_POINTER_P (gnu_type))
  3056.     gigi_abort (322);
  3057.  
  3058.   /* Checked expressions must be evaluated only once. */
  3059.   gnu_expr = make_save_expr (gnu_expr);
  3060.  
  3061.   return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
  3062.                       gnu_expr,
  3063.                       convert (TREE_TYPE (gnu_expr),
  3064.                            integer_zero_node)),
  3065.              gnu_expr);
  3066. }
  3067.  
  3068. /* Emits a discriminant check. GNU_EXPR is the expression to be checked and
  3069.    GNAT_NODE a N_Selected_Component node. */
  3070.  
  3071. static tree
  3072. emit_discriminant_check (gnu_expr, gnat_node)
  3073.      tree gnu_expr;
  3074.      Node_Id gnat_node;
  3075. {
  3076.   Entity_Id gnat_discr_fct
  3077.     = Discriminant_Checking_Func (Entity (Selector_Name (gnat_node)));
  3078.   tree gnu_discr_fct;
  3079.   Entity_Id gnat_discr;
  3080.   tree gnu_actual_list = NULL_TREE;
  3081.   tree gnu_cond;
  3082.  
  3083.   if (! Present (gnat_discr_fct))
  3084.     return gnu_expr;
  3085.  
  3086.   gnu_discr_fct = gnat_to_gnu_entity (gnat_discr_fct, NULL_TREE, 0);
  3087.  
  3088.   /* Checked expressions must be evaluated only once. */
  3089.   gnu_expr = make_save_expr (gnu_expr);
  3090.  
  3091.   /* Create the list of the actual parameters as GCC expects it.
  3092.      This list is the list of the discriminant fields of the
  3093.      record expression to be discriminant checked. For documentation
  3094.      on what is the GCC format for this list see under the
  3095.      N_Function_Call case */
  3096.   for (gnat_discr = First_Discriminant (Etype (Entity
  3097.                            (Prefix (gnat_node))));
  3098.        Present (gnat_discr); gnat_discr = Next_Discriminant (gnat_discr))
  3099.     {
  3100.       tree gnu_discr = gnat_to_gnu_entity (gnat_discr, NULL_TREE, 0);
  3101.       /* the IDENTIFIER_NODE whose name is that of the discriminant */
  3102.       tree gnu_discr_id_node
  3103.     = get_identifier (Get_Name_String (Chars (gnat_discr)));
  3104.  
  3105.       gnu_actual_list
  3106.     = chainon (gnu_actual_list,
  3107.            build_tree_list (NULL_TREE,
  3108.                     build_component_ref (gnu_expr,
  3109.                              gnu_discr_id_node,
  3110.                              gnu_discr)));
  3111.     }
  3112.  
  3113.   gnu_cond = build (CALL_EXPR,
  3114.             TREE_TYPE (TREE_TYPE (gnu_discr_fct)),
  3115.             build_unary_op (ADDR_EXPR,
  3116.                     NULL_TREE,
  3117.                     gnu_discr_fct),
  3118.             gnu_actual_list,
  3119.             NULL_TREE);
  3120.   TREE_SIDE_EFFECTS (gnu_cond) = 1;
  3121.  
  3122.   return build_unary_op (INDIRECT_REF, NULL_TREE,
  3123.              emit_check (gnu_cond,
  3124.                      build_unary_op (ADDR_EXPR, NULL_TREE,
  3125.                              gnu_expr)));
  3126. }
  3127.  
  3128. /* Emit code for a range check. GNU_EXPR is the expression to be checked,
  3129.    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
  3130.    which we have to check. */
  3131.  
  3132. static tree
  3133. emit_range_check (gnu_expr, gnat_range_type)
  3134.      tree gnu_expr;
  3135.      Entity_Id gnat_range_type;
  3136. {
  3137.   tree gnu_range_type = gnat_to_gnu_type (gnat_range_type);
  3138.   tree gnu_low  = TYPE_MIN_VALUE (gnu_range_type);
  3139.   tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
  3140.  
  3141.   /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
  3142.      we can't do anything since we might be truncating the bounds.  No
  3143.      check is needed in this case.  */
  3144.   if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
  3145.       && (TYPE_PRECISION (TREE_TYPE (gnu_expr))
  3146.       < TYPE_PRECISION (gnu_range_type)))
  3147.     return gnu_expr;
  3148.  
  3149.   /* Checked expressions must be evaluated only once. */
  3150.   gnu_expr = make_save_expr (gnu_expr);
  3151.  
  3152.   /* There's no good type to use here, so we might as well use
  3153.      integer_type_node.  */
  3154.   return emit_check
  3155.     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
  3156.               build_binary_op (LT_EXPR, integer_type_node,
  3157.                        gnu_expr,
  3158.                        convert (TREE_TYPE (gnu_expr),
  3159.                         gnu_low)),
  3160.               build_binary_op (GT_EXPR, integer_type_node,
  3161.                        gnu_expr,
  3162.                        convert (TREE_TYPE (gnu_expr),
  3163.                         gnu_high))),
  3164.      gnu_expr);
  3165. }
  3166.  
  3167. /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
  3168.    which we are about to index, GNU_EXPR is the index expression to be
  3169.    checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
  3170.    against which GNU_EXPR has to be checked. Note that for index
  3171.    checking we cannot use the emit_range_check function (although very
  3172.    similar code needs to be generated in both cases) since for index
  3173.    checking the array type against which we are checking the indeces
  3174.    may be unconstrained and consequently we need to retrieve the
  3175.    actual index bounds from the array object itself
  3176.    (GNU_ARRAY_OBJECT). The place where we need to do that is in
  3177.    subprograms having unconstrained array formal parameters */
  3178.  
  3179. static tree
  3180. emit_index_check (gnu_array_object, gnu_expr, gnu_low, gnu_high)
  3181.      tree gnu_array_object;
  3182.      tree gnu_expr;
  3183.      tree gnu_low;
  3184.      tree gnu_high;
  3185. {
  3186.   /* Checked expressions must be evaluated only once. */
  3187.   gnu_expr = make_save_expr (gnu_expr);
  3188.  
  3189.   /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
  3190.      the object we are handling. */
  3191.   if (TREE_CODE (gnu_low) != INTEGER_CST && contains_placeholder_p (gnu_low))
  3192.     gnu_low = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_low),
  3193.              gnu_low, gnu_array_object);
  3194.  
  3195.   if (TREE_CODE (gnu_high) != INTEGER_CST && contains_placeholder_p (gnu_high))
  3196.     gnu_high = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_high),
  3197.               gnu_high, gnu_array_object);
  3198.  
  3199.   /* There's no good type to use here, so we might as well use
  3200.      integer_type_node.   */
  3201.   return emit_check
  3202.     (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
  3203.               build_binary_op (LT_EXPR, integer_type_node,
  3204.                        gnu_expr,
  3205.                        convert (TREE_TYPE (gnu_expr),
  3206.                         gnu_low)),
  3207.               build_binary_op (GT_EXPR, integer_type_node,
  3208.                        gnu_expr,
  3209.                        convert (TREE_TYPE (gnu_expr),
  3210.                         gnu_high))),
  3211.      gnu_expr);
  3212. }
  3213.  
  3214. /* Given GNU_COND which contains the condition corresponding to an access,
  3215.    discriminant or range check, of value GNU_EXPR, build a COND_EXPR
  3216.    that returns GNU_EXPR if GNU_COND is false and raises a
  3217.    CONSTRAINT_ERROR if GNU_COND is true.  */
  3218.  
  3219. static tree
  3220. emit_check (gnu_cond, gnu_expr)
  3221.      tree gnu_cond;
  3222.      tree gnu_expr;
  3223. {
  3224.   tree gnu_call = build (CALL_EXPR, void_type_node,
  3225.              build_unary_op (ADDR_EXPR, NULL_TREE,
  3226.                      raise_constraint_error_decl),
  3227.              NULL_TREE, NULL_TREE);
  3228.  
  3229.   TREE_SIDE_EFFECTS (gnu_call) = 1;
  3230.  
  3231.   /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will
  3232.      get evaluated in front of the comparison in case it ends
  3233.      up being a SAVE_EXPR.  */
  3234.  
  3235.   return build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
  3236.         build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
  3237.                build (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
  3238.                   gnu_call, gnu_expr),
  3239.                gnu_expr));
  3240. }
  3241.  
  3242. /* Return an expression that does an unchecked converstion
  3243.    of GNU_EXPR to GNU_TYPE.  */
  3244.  
  3245. static tree
  3246. unchecked_convert (gnu_type, gnu_expr)
  3247.      tree gnu_type;
  3248.      tree gnu_expr;
  3249. {
  3250.   /* If the expression is already the right type, we are done.  */
  3251.   if (TREE_TYPE (gnu_expr) == gnu_type)
  3252.     return gnu_expr;
  3253.  
  3254.   /* If both types types are integral, just do a normal conversion.  */
  3255.   else if (INTEGRAL_TYPE_P (gnu_type)
  3256.       && INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr)))
  3257.     return convert (gnu_type, gnu_expr);
  3258.  
  3259.   /* We have a special case when we are converting between two
  3260.      unconstrained array types.  In that case, take the address,
  3261.      convert the fat pointer types, and dereference.  */
  3262.   else if (TREE_CODE (TREE_TYPE (gnu_expr)) == UNCONSTRAINED_ARRAY_TYPE
  3263.        && TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
  3264.     return build_unary_op (INDIRECT_REF, NULL_TREE,
  3265.                build1 (UNCHECKED_CONVERT_EXPR,
  3266.                    TREE_TYPE (gnu_type),
  3267.                    build_unary_op (ADDR_EXPR, NULL_TREE,
  3268.                            gnu_expr)));
  3269.   else
  3270.     return build1 (UNCHECKED_CONVERT_EXPR, gnu_type,
  3271.            maybe_unconstrained_array (gnu_expr));
  3272. }
  3273.  
  3274. /* Do the processing for the declaration of a GNAT_ENTITY, a type.  If
  3275.    a separate Freeze node exists, delay the bulk of the processing.  Otherwise
  3276.    make a GCC type for GNAT_ENTITY and set up the correspondance.  */
  3277.  
  3278. static void
  3279. process_type (gnat_entity)
  3280.      Entity_Id gnat_entity;
  3281. {
  3282.   tree gnu_old
  3283.     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
  3284.   tree gnu_new;
  3285.  
  3286.   /* If we are to delay elaboration of this type, just do any
  3287.      elaborations needed for expressions within the declaration and
  3288.      make a dummy type entry for this node and its Full_View (if
  3289.      any) in case something points to it.  Don't do this if it
  3290.      has already been done (the only way that can happen is if
  3291.      the private completion is also delayed).  */
  3292.   if (Present (Freeze_Node (gnat_entity)))
  3293.     {
  3294.       elaborate_entity (gnat_entity);
  3295.  
  3296.       if (gnu_old == 0)
  3297.     {
  3298.       char *entity_name = Get_Name_String (Chars (gnat_entity));
  3299.       tree gnu_type = make_dummy_type (gnat_entity);
  3300.       tree gnu_decl = create_type_decl (entity_name, gnu_type);
  3301.  
  3302.       save_gnu_tree (gnat_entity, gnu_decl, 0);
  3303.       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
  3304.           && Present (Full_View (gnat_entity)))
  3305.         save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
  3306.     }
  3307.  
  3308.       return;
  3309.     }
  3310.  
  3311.   /* If we saved away a dummy type for this node it means that this
  3312.      made the type that corresponds to the full type of an incomplete
  3313.      type.  Clear that type for now and then update the type in the
  3314.      pointers.  */
  3315.   if (gnu_old != 0)
  3316.     {
  3317.       if (TREE_CODE (gnu_old) != TYPE_DECL
  3318.       || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
  3319.     gigi_abort (323);
  3320.  
  3321.       save_gnu_tree (gnat_entity, NULL_TREE, 0);
  3322.     }
  3323.  
  3324.   /* Now fully elaborate the type.  */
  3325.   gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
  3326.   if (TREE_CODE (gnu_new) != TYPE_DECL)
  3327.     gigi_abort (324);
  3328.  
  3329.   /* If we have an old type and we've made pointers to this type,
  3330.      update those pointers.  */
  3331.   if (gnu_old != 0)
  3332.     update_pointer_to (TREE_TYPE (gnu_old), TREE_TYPE (gnu_new));
  3333.  
  3334.   /* If this is a record type corresponding to a task or protected type 
  3335.      that is a completion of an incomplete type, perform a similar update
  3336.      on the type.  */
  3337.   /* ??? Including protected types here is a guess. */
  3338.  
  3339.   if (IN (Ekind (gnat_entity), Record_Kind)
  3340.       && Is_Concurrent_Record_Type (gnat_entity)
  3341.       && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
  3342.     {
  3343.       tree gnu_task_old
  3344.     = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
  3345.  
  3346.       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
  3347.              NULL_TREE, 0);
  3348.       save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
  3349.              gnu_new, 0);
  3350.  
  3351.       update_pointer_to (TREE_TYPE (gnu_task_old), TREE_TYPE (gnu_new));
  3352.     }
  3353. }
  3354.  
  3355. /* Elaborate all implicit types of GNAT_NODE, if it has any.  Then return the
  3356.    GCC equivalent for its Etype.  */
  3357.  
  3358. static tree
  3359. elaborate_node_types (gnat_node)
  3360.      Node_Id gnat_node;
  3361. {
  3362.   if ((IN (Nkind (gnat_node), N_Has_Itypes))
  3363.       && (Present (First_Itype (gnat_node))))
  3364.     {
  3365.       Entity_Id ityp;
  3366.  
  3367.       for (ityp = First_Itype (gnat_node);
  3368.        (Present (ityp));
  3369.          ityp = Next_Itype (ityp))
  3370.     process_type (ityp);
  3371.     }
  3372.  
  3373.   return gnat_to_gnu_type (Etype (gnat_node));
  3374. }
  3375.  
  3376. /* Elaborate any implicit types of GNAT_NODE, if it has any.  */
  3377.  
  3378. void
  3379. process_implicit_types (gnat_node)
  3380.      Node_Id gnat_node;
  3381. {
  3382.   if ((IN (Nkind (gnat_node), N_Has_Itypes))
  3383.       && (Present (First_Itype (gnat_node))))
  3384.     {
  3385.       Entity_Id ityp;
  3386.  
  3387.       for (ityp = First_Itype (gnat_node);
  3388.        (Present (ityp));
  3389.          ityp = Next_Itype (ityp))
  3390.     process_type (ityp);
  3391.     }
  3392. }
  3393.  
  3394. /* GNAT_ASSOC is a sub-part (possibly the front) of the Component_Associations
  3395.    of an N_Aggregate.  GNU_TYPE is the GCC type of the corresponding
  3396.    record.  GNU_SO_FAR is the part of the CONSTRUCTOR list before the
  3397.    variant, if any so far.  This list must contain the discriminants.
  3398.    Return a CONSTRUCTOR to initialize the record.
  3399.  
  3400.    This function is called recursively to handle variant parts.  We rely
  3401.    heavily on the fact that a variant must be the last thing in a record.
  3402.  
  3403.    We also assume that the front end has sorted all the fields and eliminated
  3404.    any multiple choices.  These assumptions are verified.  */
  3405.  
  3406. static tree
  3407. assoc_to_constructor (gnat_assoc, gnu_type, gnu_so_far)
  3408.      Node_Id gnat_assoc;
  3409.      tree gnu_type;
  3410.      tree gnu_so_far;
  3411. {
  3412.   tree gnu_field, gnu_list;
  3413.  
  3414.   /* We test for GNU_FIELD being empty in the case where a variant
  3415.      was the last thing since we don't take things off GNAT_ASSOC in
  3416.      that case.  We check GNAT_ASSOC in case we have a variant, but it
  3417.      has no fields.  */
  3418.  
  3419.   for (gnu_field = TYPE_FIELDS (gnu_type), gnu_list = NULL_TREE;
  3420.        gnu_field != 0 && Present (gnat_assoc);
  3421.        gnat_assoc = Next (gnat_assoc), gnu_field = TREE_CHAIN (gnu_field))
  3422.     {
  3423.       Node_Id gnat_field = First (Choices (gnat_assoc));
  3424.       char *field_name = Get_Name_String (Chars (gnat_field));
  3425.       tree gnu_expr;
  3426.  
  3427.       /* The expander is supposed to put a single component selector name
  3428.      in every record component association */
  3429.       if (Next (gnat_field))
  3430.     gigi_abort (328);
  3431.  
  3432.       /* If this record is a subtype of a variant record that had a rep
  3433.      clause, the undefined fields won't be removed when the subtype
  3434.      is made, but the front-end won't include them.  So skip them here.  */
  3435.       while (gnu_field != 0 && DECL_FIRST_FIELD_IN_VARIANT_P (gnu_field)
  3436.          && strcmp (field_name,
  3437.             IDENTIFIER_POINTER (DECL_NAME (gnu_field))))
  3438.     for (gnu_field = TREE_CHAIN (gnu_field);
  3439.          gnu_field != 0 && ! DECL_FIRST_FIELD_IN_VARIANT_P (gnu_field);
  3440.          gnu_field = TREE_CHAIN (gnu_field))
  3441.       ;
  3442.  
  3443.       if (gnu_field == 0)
  3444.     gigi_abort (329);
  3445.  
  3446.       /* There are only three valid possibilities: GNU_FIELD is either
  3447.      an QUAL_UNION_TYPE that represents a variant part, it is the
  3448.      RECORD_TYPE that is the remnant in a constrained subtype of
  3449.      a type that had a variant, or it is the desired field.  If it is a
  3450.      variant part, find the variant whose DECL_QUALIFIER is true.  It
  3451.      might seem that we could just look for the variant with the
  3452.      proper-named field, but we might have an arbitrary number of nested
  3453.      variants before the first named field, so this is simpler.  */
  3454.  
  3455.       if (DECL_FOR_VARIANT_P (gnu_field)
  3456.       && TREE_CODE (TREE_TYPE (gnu_field)) == QUAL_UNION_TYPE)
  3457.     {
  3458.       tree gnu_variant;
  3459.       tree gnu_discrims = gnu_so_far ? gnu_so_far : gnu_list;
  3460.  
  3461.       for (gnu_variant = TYPE_FIELDS (TREE_TYPE (gnu_field));
  3462.            gnu_variant; gnu_variant = TREE_CHAIN (gnu_variant))
  3463.         {
  3464.           tree gnu_qual = DECL_QUALIFIER (gnu_variant);
  3465.           tree gnu_discrim;
  3466.  
  3467.           for (gnu_discrim = gnu_discrims;
  3468.            gnu_discrim; gnu_discrim = TREE_CHAIN (gnu_discrim))
  3469.         if (DECL_DISCRIMINANT_P (TREE_PURPOSE (gnu_discrim)))
  3470.           gnu_qual = substitute_in_expr (gnu_qual,
  3471.                          TREE_PURPOSE (gnu_discrim),
  3472.                          TREE_VALUE (gnu_discrim));
  3473.  
  3474.           /* If we found it, get the CONSTRUCTOR for the variant.
  3475.          Then surround it with a CONSTRUCTOR for
  3476.          the QUAL_UNION_TYPE.  */
  3477.           if (integer_onep (gnu_qual))
  3478.         {
  3479.           tree gnu_inner
  3480.             = assoc_to_constructor (gnat_assoc,
  3481.                         TREE_TYPE (gnu_variant),
  3482.                         gnu_discrims);
  3483.  
  3484.           gnu_expr = build_constructor (TREE_TYPE (gnu_field),
  3485.                         tree_cons (gnu_variant,
  3486.                                gnu_inner,
  3487.                                NULL_TREE));
  3488.           break;
  3489.         }
  3490.         }
  3491.     }
  3492.  
  3493.       /* Any other marked field must be the remnants of a variant.  The
  3494.      element for our constructor is just a constructor of that record.  */
  3495.       else if (DECL_FOR_VARIANT_P (gnu_field)
  3496.            && TREE_CODE (TREE_TYPE (gnu_field)) == RECORD_TYPE)
  3497.     gnu_expr = assoc_to_constructor (gnat_assoc, TREE_TYPE (gnu_field),
  3498.                      NULL_TREE);
  3499.  
  3500.       /* Otherwise, this is required to be the field we are looking for.  */
  3501.       else if (DECL_NAME (gnu_field) != 0
  3502.            && 0 == strcmp (field_name,
  3503.                    IDENTIFIER_POINTER (DECL_NAME (gnu_field))))
  3504.     {
  3505.       gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
  3506.  
  3507.       /* Before assigning a value in an aggregate make sure range checks
  3508.          are done if required.  Then convert to the type of the field.  */
  3509.       if (Do_Range_Check (Expression (gnat_assoc)))
  3510.         gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
  3511.  
  3512.       gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
  3513.     }
  3514.       else
  3515.     gigi_abort (329);
  3516.  
  3517.       /* Add the field and expression to the list.  */
  3518.       gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
  3519.     }
  3520.  
  3521.   /* Return the final CONSTRUCTOR.  We need not reverse the fields, but
  3522.      do so for cleanliness.  */
  3523.   return build_constructor (gnu_type, nreverse (gnu_list));
  3524. }
  3525.  
  3526. /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
  3527.    is the first element of an array aggregate. It may itself be an
  3528.    aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
  3529.    corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
  3530.    of the array component. It is needed for range checking. */
  3531.  
  3532. static tree
  3533. pos_to_constructor (gnat_expr, gnu_array_type, gnat_component_type)
  3534.      Node_Id gnat_expr;
  3535.      tree gnu_array_type;
  3536.      Entity_Id gnat_component_type;
  3537. {
  3538.   tree gnu_expr;
  3539.   tree gnu_expr_list = NULL_TREE;
  3540.  
  3541.   for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
  3542.     {
  3543.       /* If the expression is itself an array aggregate then first build the
  3544.      innermost constructor if it is part of our array (multi-dimensional
  3545.      case).  */
  3546.  
  3547.       if (Nkind (gnat_expr) == N_Aggregate
  3548.       && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
  3549.       && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
  3550.     gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
  3551.                        TREE_TYPE (gnu_array_type),
  3552.                        gnat_component_type);
  3553.       else
  3554.     {
  3555.       gnu_expr = gnat_to_gnu (gnat_expr);
  3556.  
  3557.       /* before assigning the element to the array make sure it is
  3558.          in range */
  3559.       if (Do_Range_Check (gnat_expr))
  3560.         gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
  3561.     }
  3562.       gnu_expr_list = tree_cons (NULL_TREE, gnu_expr, gnu_expr_list);
  3563.     }
  3564.  
  3565.   return build_constructor (gnu_array_type, nreverse (gnu_expr_list));
  3566. }
  3567.  
  3568. /* EXP is to be treated as an array or record.  Handle the cases when it is
  3569.    an access object and perform the required dereferences.  */
  3570.  
  3571. static tree
  3572. maybe_implicit_deref (exp)
  3573.      tree exp;
  3574. {
  3575.   /* If the type is a pointer, dereference it.  */
  3576.   if (TREE_CODE (TREE_TYPE (exp)) == POINTER_TYPE
  3577.       || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
  3578.     exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
  3579.  
  3580.   return exp;
  3581. }
  3582.  
  3583. /* Surround EXP with a SAVE_EXPR, but handle unconstrained objects specially
  3584.    since it doesn't make any sense to put them in a SAVE_EXPR.  */
  3585.  
  3586. tree
  3587. make_save_expr (exp)
  3588.      tree exp;
  3589. {
  3590.   tree type = TREE_TYPE (exp);
  3591.  
  3592.   /* If this is an unconstrained type, take its address, make a
  3593.      SAVE_EXPR of that, then do the indirect reference.  Note that
  3594.      for an unconstrained array, the effect will be to make a SAVE_EXPR
  3595.      of the fat pointer.  */
  3596.   if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE
  3597.       || (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST
  3598.       && contains_placeholder_p (TYPE_SIZE (type))))
  3599.     return build_unary_op (INDIRECT_REF, type,
  3600.                save_expr (build_unary_op (ADDR_EXPR,
  3601.                               NULL_TREE, exp)));
  3602.   /* Otherwise, just do the usual thing.  */
  3603.   return save_expr (exp);
  3604. }
  3605.  
  3606. /* If EXP is an UNCONSTRAINED_ARRAY_REF, return an expression that refers
  3607.    to the underlying array.  */
  3608.  
  3609. static tree
  3610. maybe_unconstrained_array (exp)
  3611.      tree exp;
  3612. {
  3613.   tree new = exp;
  3614.  
  3615.   if (TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
  3616.     {
  3617.       new = build_unary_op (INDIRECT_REF, NULL_TREE,
  3618.                 build_component_ref (TREE_OPERAND (exp, 0),
  3619.                          get_identifier ("P_ARRAY"),
  3620.                          NULL_TREE));
  3621.       TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
  3622.     }
  3623.  
  3624.   return new;
  3625. }
  3626.  
  3627. /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
  3628.    how to handle our new nodes.  */
  3629.  
  3630. static tree
  3631. gnat_stabilize_reference (ref)
  3632.      tree ref;
  3633. {
  3634.   register tree result;
  3635.   register enum tree_code code = TREE_CODE (ref);
  3636.  
  3637.   switch (code)
  3638.     {
  3639.     case VAR_DECL:
  3640.     case PARM_DECL:
  3641.     case RESULT_DECL:
  3642.       /* No action is needed in this case.  */
  3643.       return ref;
  3644.  
  3645.     case NOP_EXPR:
  3646.     case CONVERT_EXPR:
  3647.     case FLOAT_EXPR:
  3648.     case FIX_TRUNC_EXPR:
  3649.     case FIX_FLOOR_EXPR:
  3650.     case FIX_ROUND_EXPR:
  3651.     case FIX_CEIL_EXPR:
  3652.     case UNCHECKED_CONVERT_EXPR:
  3653.       result
  3654.     = build_nt (code, gnat_stabilize_reference (TREE_OPERAND (ref, 0)));
  3655.       break;
  3656.  
  3657.     case INDIRECT_REF:
  3658.     case UNCONSTRAINED_ARRAY_REF:
  3659.       result = build_nt (code,
  3660.              stabilize_reference_1 (TREE_OPERAND (ref, 0)));
  3661.       break;
  3662.  
  3663.     case COMPONENT_REF:
  3664.       result = build_nt (COMPONENT_REF,
  3665.              gnat_stabilize_reference (TREE_OPERAND (ref, 0)),
  3666.              TREE_OPERAND (ref, 1));
  3667.       break;
  3668.  
  3669.     case BIT_FIELD_REF:
  3670.       result = build_nt (BIT_FIELD_REF,
  3671.              gnat_stabilize_reference (TREE_OPERAND (ref, 0)),
  3672.              stabilize_reference_1 (TREE_OPERAND (ref, 1)),
  3673.              stabilize_reference_1 (TREE_OPERAND (ref, 2)));
  3674.       break;
  3675.  
  3676.     case ARRAY_REF:
  3677.       result = build_nt (ARRAY_REF,
  3678.              gnat_stabilize_reference (TREE_OPERAND (ref, 0)),
  3679.              stabilize_reference_1 (TREE_OPERAND (ref, 1)));
  3680.       break;
  3681.  
  3682.     case COMPOUND_EXPR:
  3683.       result = build_nt (COMPOUND_EXPR,
  3684.              stabilize_reference_1 (TREE_OPERAND (ref, 0)),
  3685.              gnat_stabilize_reference (TREE_OPERAND (ref, 1)));
  3686.       break;
  3687.  
  3688.     case RTL_EXPR:
  3689.       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
  3690.                save_expr (build1 (ADDR_EXPR,
  3691.                       build_pointer_type (TREE_TYPE (ref)),
  3692.                       ref)));
  3693.       break;
  3694.  
  3695.       /* If arg isn't a kind of lvalue we recognize, make no change.
  3696.      Caller should recognize the error for an invalid lvalue.  */
  3697.     default:
  3698.       return ref;
  3699.  
  3700.     case ERROR_MARK:
  3701.       return error_mark_node;
  3702.     }
  3703.  
  3704.   TREE_TYPE (result) = TREE_TYPE (ref);
  3705.   TREE_READONLY (result) = TREE_READONLY (ref);
  3706.   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
  3707.   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
  3708.   TREE_RAISES (result) = TREE_RAISES (ref);
  3709.  
  3710.   return result;
  3711. }
  3712.  
  3713. /* GNAT_UNIT is the Defining_Identifier for some package, either a
  3714.    spec or a body, BODY_P says which.  If needed, make a function to be the
  3715.    elaboration routine for that object and perform the elaborations
  3716.    in GNU_ELAB_LIST.
  3717.  
  3718.    Return 1 if we didn't need an elaboration function, zero otherwise.  */
  3719.  
  3720. static int
  3721. build_package_elab (gnat_unit, body_p, gnu_elab_list, gnat_statements)
  3722.      Entity_Id gnat_unit;
  3723.      int body_p;
  3724.      tree gnu_elab_list;
  3725.      Node_Id gnat_statements;
  3726. {
  3727.   tree gnu_decl;
  3728.   struct elab_list *elab;
  3729.  
  3730.   /* If we have nothing to do, return.  */
  3731.   if (gnu_elab_list == 0 && No (gnat_statements))
  3732.     return 1;
  3733.  
  3734.   /* Set our file and line number to that of the object and set up the
  3735.      elaboration routine.  */
  3736.   gnu_decl = create_subprog_decl (create_concat_name (gnat_unit,
  3737.                               body_p ?
  3738.                               "elabb" : "elabs"),
  3739.                   0, void_ftype, NULL_TREE, 0, 1, 0, 0,
  3740.                   NULL_TREE);
  3741.  
  3742.   begin_subprog_body (gnu_decl);
  3743.   set_lineno (gnat_unit, 1);
  3744.   pushlevel (0);
  3745.   expand_start_bindings (0);
  3746.  
  3747.   /* Emit the assignments for the elaborations we have to do.  If there
  3748.      is no destination, this is just a call to execute some statement
  3749.      that was placed within the declarative region.  */
  3750.   for (; gnu_elab_list; gnu_elab_list = TREE_CHAIN (gnu_elab_list))
  3751.     if (TREE_PURPOSE (gnu_elab_list) == NULL_TREE)
  3752.       expand_expr_stmt (TREE_VALUE (gnu_elab_list));
  3753.     else
  3754.       {
  3755.     input_filename = DECL_SOURCE_FILE (TREE_PURPOSE (gnu_elab_list));
  3756.     lineno = DECL_SOURCE_LINE (TREE_PURPOSE (gnu_elab_list));
  3757.  
  3758.     emit_line_note (input_filename, lineno);
  3759.     expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE,
  3760.                        TREE_PURPOSE (gnu_elab_list),
  3761.                        TREE_VALUE (gnu_elab_list)));
  3762.       }
  3763.  
  3764.   /* Now generate code for any actual statements in the body.  */
  3765.   if (Present (gnat_statements))
  3766.     gnat_to_code (gnat_statements);
  3767.  
  3768.   expand_end_bindings (getdecls (), 1, 0);
  3769.   poplevel (0, 0, 0);
  3770.   end_subprog_body ();
  3771.  
  3772.   return 0;
  3773. }
  3774.  
  3775. /* GNAT_UNIT is the Defining_Identifier for some subprogram.
  3776.    Make elaboration functions for the spec or body of it.
  3777.    Currently the function just returns -- eventually it may
  3778.    have some elaboration order checks in it.
  3779.  
  3780.    Return 1 if we don't need any elaboration functions (currently
  3781.    always the case), zero otherwise.  */
  3782.  
  3783. static int
  3784. build_subprogram_elab (gnat_unit, body_p)
  3785.      Entity_Id gnat_unit;
  3786.      int body_p;
  3787. {
  3788.   return 1;
  3789.  
  3790. #if 0
  3791.   tree gnu_decl;
  3792.  
  3793.   /* Set our file and line number to that of the object and set up the
  3794.      elaboration routine.  */
  3795.   gnu_decl
  3796.     = create_subprog_decl (create_concat_name (gnat_unit,
  3797.                            body_p ? "elabb" : "elabs"),
  3798.                0, void_ftype, NULL_TREE, 0, 1, 0, 0, NULL_TREE);
  3799.   begin_subprog_body (gnu_decl);
  3800.   set_lineno (gnat_unit, 1);
  3801.   pushlevel (0);
  3802.   expand_start_bindings (0);
  3803.  
  3804.   expand_end_bindings (getdecls (), 1, 0);
  3805.   poplevel (0, 0, 0);
  3806.   end_subprog_body ();
  3807.  
  3808.   return 0;
  3809. #endif
  3810. }
  3811.  
  3812. /* Define names for some functions in sinput.adb we call from here.  */
  3813.  
  3814. #define Full_File_Name        sinput__full_file_name
  3815. #define Get_Source_File_Index    sinput__get_source_file_index
  3816. #define Get_Line_Number        sinput__get_line_number
  3817.  
  3818. /* Determine the input_filename and the lineno from the source location
  3819.    (Sloc) of GNAT_NODE node.  Set the global variable input_filename and
  3820.    lineno.  If WRITE_NOTE_P is true, emit a line number note.  */
  3821.  
  3822. void
  3823. set_lineno (gnat_node, write_note_p)
  3824.      Node_Id gnat_node;
  3825.      int write_note_p;
  3826. {
  3827.   extern Int Number_Units;
  3828.   extern struct Needed_File_Info *File_Info_Ptr;
  3829.   int current_unit_number;
  3830.   int Num_Source_Lines;
  3831.   Source_Ptr source_location = Sloc (gnat_node);
  3832.   int Lo = 0;
  3833.   int Hi;
  3834.   int Mid;
  3835.  
  3836.   /* If node not from source code, ignore.  */
  3837.   if (source_location < 0)
  3838.     return;
  3839.  
  3840.   input_filename
  3841.     = Get_Name_String
  3842.       (Full_File_Name (Get_Source_File_Index (source_location)));
  3843.   lineno = Get_Line_Number (source_location);
  3844.  
  3845.   if (write_note_p)
  3846.     emit_line_note (input_filename, lineno);
  3847. }
  3848.  
  3849. /* Post an error message.  MSG is the error message, properly annotated.
  3850.    NODE is the node at which to post the error and the node to use for the
  3851.    "&" substitution.  */
  3852.  
  3853. void
  3854. post_error (msg, node)
  3855.      char *msg;
  3856.      Node_Id node;
  3857. {
  3858.   struct template {int first, last; } temp = {1, strlen (msg)};
  3859.   struct fat_pointer { char *array; struct template *temp; } fp = {msg, &temp};
  3860.  
  3861.   errout__error_msg_n (fp, node);
  3862. }
  3863.  
  3864. /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
  3865.    as the relevant node that provides the location info for the error */
  3866.  
  3867. void
  3868. gigi_abort (code)
  3869.      int code;
  3870. {
  3871.   struct template {int first, last; } temp = {1, 10};
  3872.   struct fat_pointer { char *array; struct template *temp; }
  3873.                                             fp = {"Gigi abort", &temp};
  3874.   extern comperr__compiler_abort PROTO((struct fat_pointer, int))
  3875.     __attribute__ ((noreturn));
  3876.   extern Node_Id debug__fatal_error_node;
  3877.  
  3878.   debug__fatal_error_node = error_gnat_node;
  3879.   comperr__compiler_abort (fp, code);
  3880. }
  3881.  
  3882. /* Initialize the table that maps GNAT codes to GCC codes for simple
  3883.    binary and unary operations.  */
  3884.  
  3885. void
  3886. init_code_table ()
  3887. {
  3888.   gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
  3889.   gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
  3890.  
  3891.   gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
  3892.   gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
  3893.   gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
  3894.   gnu_codes[N_Op_Eq] = EQ_EXPR;
  3895.   gnu_codes[N_Op_Ne] = NE_EXPR;
  3896.   gnu_codes[N_Op_Lt] = LT_EXPR;
  3897.   gnu_codes[N_Op_Le] = LE_EXPR;
  3898.   gnu_codes[N_Op_Gt] = GT_EXPR;
  3899.   gnu_codes[N_Op_Ge] = GE_EXPR;
  3900.   gnu_codes[N_Op_Add] = PLUS_EXPR;
  3901.   gnu_codes[N_Op_Subtract] = MINUS_EXPR;
  3902.   gnu_codes[N_Op_Multiply] = MULT_EXPR;
  3903.   gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
  3904.   gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
  3905.   gnu_codes[N_Op_Expon] = EXPON_EXPR;
  3906.   gnu_codes[N_Op_Minus] = NEGATE_EXPR;
  3907.   gnu_codes[N_Op_Abs] = ABS_EXPR;
  3908.   gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
  3909.   gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
  3910.   gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
  3911.   gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
  3912.   gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
  3913.   gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
  3914. }
  3915.