Subversion Repositories openrisc

/****************************************************************************

 *                                                                          *

 *                         GNAT COMPILER COMPONENTS                         *

 *                                                                          *

 *                                T R A N S                                 *

 *                                                                          *

 *                          C Implementation File                           *

 *                                                                          *

 *          Copyright (C) 1992-2012, Free Software Foundation, Inc.         *

 *                                                                          *

 * GNAT is free software;  you can  redistribute it  and/or modify it under *

 * terms of the  GNU General Public License as published  by the Free Soft- *

 * ware  Foundation;  either version 3,  or (at your option) any later ver- *

 * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *

 * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *

 * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *

 * for  more details.  You should have  received  a copy of the GNU General *

 * Public License  distributed  with GNAT;  see file  COPYING3.  If not see *

 * <http://www.gnu.org/licenses/>.                                          *

 *                                                                          *

 * GNAT was originally developed  by the GNAT team at  New York University. *

 * Extensive contributions were provided by Ada Core Technologies Inc.      *

 *                                                                          *

 ****************************************************************************/

#include "config.h"

#include "system.h"

#include "coretypes.h"

#include "tm.h"

#include "tree.h"

#include "flags.h"

#include "ggc.h"

#include "output.h"

#include "libfuncs.h"   /* For set_stack_check_libfunc.  */

#include "tree-iterator.h"

#include "gimple.h"

#include "bitmap.h"

#include "cgraph.h"

#include "ada.h"

#include "adadecode.h"

#include "types.h"

#include "atree.h"

#include "elists.h"

#include "namet.h"

#include "nlists.h"

#include "snames.h"

#include "stringt.h"

#include "uintp.h"

#include "urealp.h"

#include "fe.h"

#include "sinfo.h"

#include "einfo.h"

#include "gadaint.h"

#include "ada-tree.h"

#include "gigi.h"

/* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,

   for fear of running out of stack space.  If we need more, we use xmalloc

   instead.  */

#define ALLOCA_THRESHOLD 1000

/* Let code below know whether we are targetting VMS without need of

   intrusive preprocessor directives.  */

#ifndef TARGET_ABI_OPEN_VMS

#define TARGET_ABI_OPEN_VMS 0

#endif

/* In configurations where blocks have no end_locus attached, just

   sink assignments into a dummy global.  */

#ifndef BLOCK_SOURCE_END_LOCATION

static location_t block_end_locus_sink;

#define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink

#endif

/* For efficient float-to-int rounding, it is necessary to know whether

   floating-point arithmetic may use wider intermediate results.  When

   FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume

   that arithmetic does not widen if double precision is emulated.  */

#ifndef FP_ARITH_MAY_WIDEN

#if defined(HAVE_extendsfdf2)

#define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2

#else

#define FP_ARITH_MAY_WIDEN 0

#endif

#endif

/* Pointers to front-end tables accessed through macros.  */

struct Node *Nodes_Ptr;

Node_Id *Next_Node_Ptr;

Node_Id *Prev_Node_Ptr;

struct Elist_Header *Elists_Ptr;

struct Elmt_Item *Elmts_Ptr;

struct String_Entry *Strings_Ptr;

Char_Code *String_Chars_Ptr;

struct List_Header *List_Headers_Ptr;

/* Highest number in the front-end node table.  */

int max_gnat_nodes;

/* Current node being treated, in case abort called.  */

Node_Id error_gnat_node;

/* True when gigi is being called on an analyzed but unexpanded

   tree, and the only purpose of the call is to properly annotate

   types with representation information.  */

bool type_annotate_only;

/* Current filename without path.  */

const char *ref_filename;

/* When not optimizing, we cache the 'First, 'Last and 'Length attributes

   of unconstrained array IN parameters to avoid emitting a great deal of

   redundant instructions to recompute them each time.  */

struct GTY (()) parm_attr_d {

  int id; /* GTY doesn't like Entity_Id.  */

  int dim;

  tree first;

  tree last;

  tree length;

};

typedef struct parm_attr_d *parm_attr;

DEF_VEC_P(parm_attr);

DEF_VEC_ALLOC_P(parm_attr,gc);

struct GTY(()) language_function {

  VEC(parm_attr,gc) *parm_attr_cache;

  bitmap named_ret_val;

  VEC(tree,gc) *other_ret_val;

  int gnat_ret;

};

#define f_parm_attr_cache \

  DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache

#define f_named_ret_val \

  DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val

#define f_other_ret_val \

  DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val

#define f_gnat_ret \

  DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret

/* A structure used to gather together information about a statement group.

   We use this to gather related statements, for example the "then" part

   of a IF.  In the case where it represents a lexical scope, we may also

   have a BLOCK node corresponding to it and/or cleanups.  */

struct GTY((chain_next ("%h.previous"))) stmt_group {

  struct stmt_group *previous;  /* Previous code group.  */

  tree stmt_list;               /* List of statements for this code group.  */

  tree block;                   /* BLOCK for this code group, if any.  */

  tree cleanups;                /* Cleanups for this code group, if any.  */

};

static GTY(()) struct stmt_group *current_stmt_group;

/* List of unused struct stmt_group nodes.  */

static GTY((deletable)) struct stmt_group *stmt_group_free_list;

/* A structure used to record information on elaboration procedures

   we've made and need to process.

   ??? gnat_node should be Node_Id, but gengtype gets confused.  */

struct GTY((chain_next ("%h.next"))) elab_info {

  struct elab_info *next;       /* Pointer to next in chain.  */

  tree elab_proc;               /* Elaboration procedure.  */

  int gnat_node;                /* The N_Compilation_Unit.  */

};

static GTY(()) struct elab_info *elab_info_list;

/* Stack of exception pointer variables.  Each entry is the VAR_DECL

   that stores the address of the raised exception.  Nonzero means we

   are in an exception handler.  Not used in the zero-cost case.  */

static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack;

/* In ZCX case, current exception pointer.  Used to re-raise it.  */

static GTY(()) tree gnu_incoming_exc_ptr;

/* Stack for storing the current elaboration procedure decl.  */

static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack;

/* Stack of labels to be used as a goto target instead of a return in

   some functions.  See processing for N_Subprogram_Body.  */

static GTY(()) VEC(tree,gc) *gnu_return_label_stack;

/* Stack of variable for the return value of a function with copy-in/copy-out

   parameters.  See processing for N_Subprogram_Body.  */

static GTY(()) VEC(tree,gc) *gnu_return_var_stack;

/* Structure used to record information for a range check.  */

struct GTY(()) range_check_info_d {

  tree low_bound;

  tree high_bound;

  tree type;

  tree invariant_cond;

};

typedef struct range_check_info_d *range_check_info;

DEF_VEC_P(range_check_info);

DEF_VEC_ALLOC_P(range_check_info,gc);

/* Structure used to record information for a loop.  */

struct GTY(()) loop_info_d {

  tree label;

  tree loop_var;

  VEC(range_check_info,gc) *checks;

};

typedef struct loop_info_d *loop_info;

DEF_VEC_P(loop_info);

DEF_VEC_ALLOC_P(loop_info,gc);

/* Stack of loop_info structures associated with LOOP_STMT nodes.  */

static GTY(()) VEC(loop_info,gc) *gnu_loop_stack;

/* The stacks for N_{Push,Pop}_*_Label.  */

static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack;

static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack;

static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack;

/* Map GNAT tree codes to GCC tree codes for simple expressions.  */

static enum tree_code gnu_codes[Number_Node_Kinds];

static void init_code_table (void);

static void Compilation_Unit_to_gnu (Node_Id);

static void record_code_position (Node_Id);

static void insert_code_for (Node_Id);

static void add_cleanup (tree, Node_Id);

static void add_stmt_list (List_Id);

static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id);

static tree build_stmt_group (List_Id, bool);

static enum gimplify_status gnat_gimplify_stmt (tree *);

static void elaborate_all_entities (Node_Id);

static void process_freeze_entity (Node_Id);

static void process_decls (List_Id, List_Id, Node_Id, bool, bool);

static tree emit_range_check (tree, Node_Id, Node_Id);

static tree emit_index_check (tree, tree, tree, tree, Node_Id);

static tree emit_check (tree, tree, int, Node_Id);

static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);

static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);

static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);

static bool addressable_p (tree, tree);

static tree assoc_to_constructor (Entity_Id, Node_Id, tree);

static tree extract_values (tree, tree);

static tree pos_to_constructor (Node_Id, tree, Entity_Id);

static tree maybe_implicit_deref (tree);

static void set_expr_location_from_node (tree, Node_Id);

static bool set_end_locus_from_node (tree, Node_Id);

static void set_gnu_expr_location_from_node (tree, Node_Id);

static int lvalue_required_p (Node_Id, tree, bool, bool, bool);

static tree build_raise_check (int, enum exception_info_kind);

static tree create_init_temporary (const char *, tree, tree *, Node_Id);

/* Hooks for debug info back-ends, only supported and used in a restricted set

   of configurations.  */

static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;

static const char *decode_name (const char *) ATTRIBUTE_UNUSED;

/* This is the main program of the back-end.  It sets up all the table

   structures and then generates code.  */

void

gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,

      struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,

      struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,

      struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,

      struct List_Header *list_headers_ptr, Nat number_file,

      struct File_Info_Type *file_info_ptr,

      Entity_Id standard_boolean, Entity_Id standard_integer,

      Entity_Id standard_character, Entity_Id standard_long_long_float,

      Entity_Id standard_exception_type, Int gigi_operating_mode)

{

  Entity_Id gnat_literal;

  tree long_long_float_type, exception_type, t, ftype;

  tree int64_type = gnat_type_for_size (64, 0);

  struct elab_info *info;

  int i;

  max_gnat_nodes = max_gnat_node;

  Nodes_Ptr = nodes_ptr;

  Next_Node_Ptr = next_node_ptr;

  Prev_Node_Ptr = prev_node_ptr;

  Elists_Ptr = elists_ptr;

  Elmts_Ptr = elmts_ptr;

  Strings_Ptr = strings_ptr;

  String_Chars_Ptr = string_chars_ptr;

  List_Headers_Ptr = list_headers_ptr;

  type_annotate_only = (gigi_operating_mode == 1);

  for (i = 0; i < number_file; i++)

    {

      /* Use the identifier table to make a permanent copy of the filename as

         the name table gets reallocated after Gigi returns but before all the

         debugging information is output.  The __gnat_to_canonical_file_spec

         call translates filenames from pragmas Source_Reference that contain

         host style syntax not understood by gdb.  */

      const char *filename

        = IDENTIFIER_POINTER

           (get_identifier

            (__gnat_to_canonical_file_spec

             (Get_Name_String (file_info_ptr[i].File_Name))));

      /* We rely on the order isomorphism between files and line maps.  */

      gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i);

      /* We create the line map for a source file at once, with a fixed number

         of columns chosen to avoid jumping over the next power of 2.  */

      linemap_add (line_table, LC_ENTER, 0, filename, 1);

      linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);

      linemap_position_for_column (line_table, 252 - 1);

      linemap_add (line_table, LC_LEAVE, 0, NULL, 0);

    }

  gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);

  /* Declare the name of the compilation unit as the first global

     name in order to make the middle-end fully deterministic.  */

  t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);

  first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));

  /* Initialize ourselves.  */

  init_code_table ();

  init_gnat_to_gnu ();

  init_dummy_type ();

  /* If we are just annotating types, give VOID_TYPE zero sizes to avoid

     errors.  */

  if (type_annotate_only)

    {

      TYPE_SIZE (void_type_node) = bitsize_zero_node;

      TYPE_SIZE_UNIT (void_type_node) = size_zero_node;

    }

  /* Enable GNAT stack checking method if needed */

  if (!Stack_Check_Probes_On_Target)

    set_stack_check_libfunc ("_gnat_stack_check");

  /* Retrieve alignment settings.  */

  double_float_alignment = get_target_double_float_alignment ();

  double_scalar_alignment = get_target_double_scalar_alignment ();

  /* Record the builtin types.  Define `integer' and `character' first so that

     dbx will output them first.  */

  record_builtin_type ("integer", integer_type_node, false);

  record_builtin_type ("character", unsigned_char_type_node, false);

  record_builtin_type ("boolean", boolean_type_node, false);

  record_builtin_type ("void", void_type_node, false);

  /* Save the type we made for integer as the type for Standard.Integer.  */

  save_gnu_tree (Base_Type (standard_integer),

                 TYPE_NAME (integer_type_node),

                 false);

  /* Likewise for character as the type for Standard.Character.  */

  save_gnu_tree (Base_Type (standard_character),

                 TYPE_NAME (unsigned_char_type_node),

                 false);

  /* Likewise for boolean as the type for Standard.Boolean.  */

  save_gnu_tree (Base_Type (standard_boolean),

                 TYPE_NAME (boolean_type_node),

                 false);

  gnat_literal = First_Literal (Base_Type (standard_boolean));

  t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);

  gcc_assert (t == boolean_false_node);

  t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,

                       boolean_type_node, t, true, false, false, false,

                       NULL, gnat_literal);

  DECL_IGNORED_P (t) = 1;

  save_gnu_tree (gnat_literal, t, false);

  gnat_literal = Next_Literal (gnat_literal);

  t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);

  gcc_assert (t == boolean_true_node);

  t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,

                       boolean_type_node, t, true, false, false, false,

                       NULL, gnat_literal);

  DECL_IGNORED_P (t) = 1;

  save_gnu_tree (gnat_literal, t, false);

  void_ftype = build_function_type_list (void_type_node, NULL_TREE);

  ptr_void_ftype = build_pointer_type (void_ftype);

  /* Now declare run-time functions.  */

  ftype = build_function_type_list (ptr_void_type_node, sizetype, NULL_TREE);

  /* malloc is a function declaration tree for a function to allocate

     memory.  */

  malloc_decl

    = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,

                           ftype, NULL_TREE, false, true, true, true, NULL,

                           Empty);

  DECL_IS_MALLOC (malloc_decl) = 1;

  /* malloc32 is a function declaration tree for a function to allocate

     32-bit memory on a 64-bit system.  Needed only on 64-bit VMS.  */

  malloc32_decl

    = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,

                           ftype, NULL_TREE, false, true, true, true, NULL,

                           Empty);

  DECL_IS_MALLOC (malloc32_decl) = 1;

  /* free is a function declaration tree for a function to free memory.  */

  free_decl

    = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,

                           build_function_type_list (void_type_node,

                                                     ptr_void_type_node,

                                                     NULL_TREE),

                           NULL_TREE, false, true, true, true, NULL, Empty);

  /* This is used for 64-bit multiplication with overflow checking.  */

  mulv64_decl

    = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,

                           build_function_type_list (int64_type, int64_type,

                                                     int64_type, NULL_TREE),

                           NULL_TREE, false, true, true, true, NULL, Empty);

  /* Name of the _Parent field in tagged record types.  */

  parent_name_id = get_identifier (Get_Name_String (Name_uParent));

  /* Name of the Exception_Data type defined in System.Standard_Library.  */

  exception_data_name_id

    = get_identifier ("system__standard_library__exception_data");

  /* Make the types and functions used for exception processing.  */

  jmpbuf_type

    = build_array_type (gnat_type_for_mode (Pmode, 0),

                        build_index_type (size_int (5)));

  record_builtin_type ("JMPBUF_T", jmpbuf_type, true);

  jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);

  /* Functions to get and set the jumpbuf pointer for the current thread.  */

  get_jmpbuf_decl

    = create_subprog_decl

      (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),

       NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),

       NULL_TREE, false, true, true, true, NULL, Empty);

  DECL_IGNORED_P (get_jmpbuf_decl) = 1;

  set_jmpbuf_decl

    = create_subprog_decl

      (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),

       NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,

                                            NULL_TREE),

       NULL_TREE, false, true, true, true, NULL, Empty);

  DECL_IGNORED_P (set_jmpbuf_decl) = 1;

  /* setjmp returns an integer and has one operand, which is a pointer to

     a jmpbuf.  */

  setjmp_decl

    = create_subprog_decl

      (get_identifier ("__builtin_setjmp"), NULL_TREE,

       build_function_type_list (integer_type_node, jmpbuf_ptr_type,

                                 NULL_TREE),

       NULL_TREE, false, true, true, true, NULL, Empty);

  DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;

  DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;

  /* update_setjmp_buf updates a setjmp buffer from the current stack pointer

     address.  */

  update_setjmp_buf_decl

    = create_subprog_decl

      (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,

       build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),

       NULL_TREE, false, true, true, true, NULL, Empty);

  DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;

  DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;

  /* Hooks to call when entering/leaving an exception handler.  */

  ftype

    = build_function_type_list (void_type_node, ptr_void_type_node, NULL_TREE);

  begin_handler_decl

    = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,

                           ftype, NULL_TREE, false, true, true, true, NULL,

                           Empty);

  DECL_IGNORED_P (begin_handler_decl) = 1;

  end_handler_decl

    = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,

                           ftype, NULL_TREE, false, true, true, true, NULL,

                           Empty);

  DECL_IGNORED_P (end_handler_decl) = 1;

  reraise_zcx_decl

    = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,

                           ftype, NULL_TREE, false, true, true, true, NULL,

                           Empty);

  DECL_IGNORED_P (reraise_zcx_decl) = 1;

  /* If in no exception handlers mode, all raise statements are redirected to

     __gnat_last_chance_handler.  No need to redefine raise_nodefer_decl since

     this procedure will never be called in this mode.  */

  if (No_Exception_Handlers_Set ())

    {

      tree decl

        = create_subprog_decl

          (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,

           build_function_type_list (void_type_node,

                                     build_pointer_type

                                     (unsigned_char_type_node),

                                     integer_type_node, NULL_TREE),

           NULL_TREE, false, true, true, true, NULL, Empty);

      TREE_THIS_VOLATILE (decl) = 1;

      TREE_SIDE_EFFECTS (decl) = 1;

      TREE_TYPE (decl)

        = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);

      for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)

        gnat_raise_decls[i] = decl;

    }

  else

    {

      /* Otherwise, make one decl for each exception reason.  */

      for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)

        gnat_raise_decls[i] = build_raise_check (i, exception_simple);

      for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)

        gnat_raise_decls_ext[i]

          = build_raise_check (i,

                               i == CE_Index_Check_Failed

                               || i == CE_Range_Check_Failed

                               || i == CE_Invalid_Data

                               ? exception_range : exception_column);

    }

  /* Set the types that GCC and Gigi use from the front end.  */

  exception_type

    = gnat_to_gnu_entity (Base_Type (standard_exception_type),  NULL_TREE, 0);

  except_type_node = TREE_TYPE (exception_type);

  /* Make other functions used for exception processing.  */

  get_excptr_decl

    = create_subprog_decl

      (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,

       build_function_type_list (build_pointer_type (except_type_node),

                                 NULL_TREE),

     NULL_TREE, false, true, true, true, NULL, Empty);

  raise_nodefer_decl

    = create_subprog_decl

      (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,

       build_function_type_list (void_type_node,

                                 build_pointer_type (except_type_node),

                                 NULL_TREE),

       NULL_TREE, false, true, true, true, NULL, Empty);

  /* Indicate that it never returns.  */

  TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;

  TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;

  TREE_TYPE (raise_nodefer_decl)

    = build_qualified_type (TREE_TYPE (raise_nodefer_decl),

                            TYPE_QUAL_VOLATILE);

  /* Build the special descriptor type and its null node if needed.  */

  if (TARGET_VTABLE_USES_DESCRIPTORS)

    {

      tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);

      tree field_list = NULL_TREE;

      int j;

      VEC(constructor_elt,gc) *null_vec = NULL;

      constructor_elt *elt;

      fdesc_type_node = make_node (RECORD_TYPE);

      VEC_safe_grow (constructor_elt, gc, null_vec,

                     TARGET_VTABLE_USES_DESCRIPTORS);

      elt = (VEC_address (constructor_elt,null_vec)

             + TARGET_VTABLE_USES_DESCRIPTORS - 1);

      for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)

        {

          tree field

            = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,

                                 NULL_TREE, NULL_TREE, 0, 1);

          DECL_CHAIN (field) = field_list;

          field_list = field;

          elt->index = field;

          elt->value = null_node;

          elt--;

        }

      finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);

      record_builtin_type ("descriptor", fdesc_type_node, true);

      null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);

    }

  long_long_float_type

    = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);

  if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)

    {

      /* In this case, the builtin floating point types are VAX float,

         so make up a type for use.  */

      longest_float_type_node = make_node (REAL_TYPE);

      TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;

      layout_type (longest_float_type_node);

      record_builtin_type ("longest float type", longest_float_type_node,

                           false);

    }

  else

    longest_float_type_node = TREE_TYPE (long_long_float_type);

  /* Dummy objects to materialize "others" and "all others" in the exception

     tables.  These are exported by a-exexpr-gcc.adb, so see this unit for

     the types to use.  */

  others_decl

    = create_var_decl (get_identifier ("OTHERS"),

                       get_identifier ("__gnat_others_value"),

                       integer_type_node, NULL_TREE, true, false, true, false,

                       NULL, Empty);

  all_others_decl

    = create_var_decl (get_identifier ("ALL_OTHERS"),

                       get_identifier ("__gnat_all_others_value"),

                       integer_type_node, NULL_TREE, true, false, true, false,

                       NULL, Empty);

  main_identifier_node = get_identifier ("main");

  /* Install the builtins we might need, either internally or as

     user available facilities for Intrinsic imports.  */

  gnat_install_builtins ();

  VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE);

  VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE);

  VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE);

  VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE);

  /* Process any Pragma Ident for the main unit.  */

#ifdef ASM_OUTPUT_IDENT

  if (Present (Ident_String (Main_Unit)))

    ASM_OUTPUT_IDENT

      (asm_out_file,

       TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));

#endif

  /* If we are using the GCC exception mechanism, let GCC know.  */

  if (Exception_Mechanism == Back_End_Exceptions)

    gnat_init_gcc_eh ();

  /* Now translate the compilation unit proper.  */

  Compilation_Unit_to_gnu (gnat_root);

  /* Finally see if we have any elaboration procedures to deal with.  */

  for (info = elab_info_list; info; info = info->next)

    {

      tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;

      /* We should have a BIND_EXPR but it may not have any statements in it.

         If it doesn't have any, we have nothing to do except for setting the

         flag on the GNAT node.  Otherwise, process the function as others.  */

      gnu_stmts = gnu_body;

      if (TREE_CODE (gnu_stmts) == BIND_EXPR)

        gnu_stmts = BIND_EXPR_BODY (gnu_stmts);

      if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))

        Set_Has_No_Elaboration_Code (info->gnat_node, 1);

      else

        {

          begin_subprog_body (info->elab_proc);

          end_subprog_body (gnu_body);

          rest_of_subprog_body_compilation (info->elab_proc);

        }

    }

  /* We cannot track the location of errors past this point.  */

  error_gnat_node = Empty;