gigi.h, trans.c (Identifier_to_gnu): Change test for deferred constant by adding…

gigi.h, trans.c (Identifier_to_gnu): Change test for deferred constant by adding guard that the entity is an...

2007-04-20  Gary Dismukes  <dismukes@adacore.com>
	    Eric Botcazou  <ebotcazou@adacore.com>
	    Tristan Gingold  <gingold@adacore.com>
	    Olivier Hainque  <hainque@adacore.com>

	* gigi.h, trans.c (Identifier_to_gnu): Change test for deferred
	constant by adding guard that the entity is an E_Constant before
	testing presence of Full_view (and remove now-unnecessary test that
	entity is not a type).
	For a CONST_DECL used by reference, manually retrieve
	the DECL_INITIAL.  Do not invoke fold in the other DECL_P cases either.
	(struct language_function): Move from utils.c to here.
	(struct parm_attr): New structure.
	(parm_attr, parm_attr vector, parm_attr GC vector): New types.
	(f_parm_attr_cache): New macro.
	(Attribute_to_gnu) <Attr_Length>: When not optimizing, cache the
	expressions for the 'First, 'Last and 'Length attributes of the
	unconstrained array IN parameters.
	(Subprogram_Body_to_gnu): Use gnu_subprog_decl throughout.
	Allocate the information structure for the function earlier, as well
	as the language-specific part.
	If the parameter attributes cache has been populated, evaluate the
	cached expressions on entry.
	(takes_address): Add OPERAND_TYPE parameter.  Handle N_Function_Call,
	N_Procedure_Call_Statement and N_Indexed_Component.
	(Pragma_to_gnu): Translate inspection_point to an asm statement
	containaing a comment and a reference to the object (either its address
	for BLKmode or its value).
	(Identifier_to_gnu): Use TREE_CONSTANT instead of CONST_DECL to decide
	to go to DECL_INITIAL. Together with the size constraint relaxation
	in create_var_decl, enlarges the set of situations in which an
	identifier may be used as an initializer without implying elaboration
	code.
	(Subprogram_Body_to_gnu): Do not fiddle with the debug interface but set
	DECL_IGNORED_P on the function if Needs_Debug_Info is not set on the
	node.
	(maybe_stabilize_reference): Remove lvalues_only parameter.
	(gnat_stabilize_reference): Adjust for above change.
	(gnat_to_gnu): Do not set location information on the result
	if it is a reference.
	(add_cleanup): Add gnat_node parameter and set the location of the
	cleanup to it.
	(Handled_Sequence_Of_Statements_to_gnu): Adjust calls to add_cleanup.
	(Exception_Handler_to_gnu_zcx): Likewise.
	(gigi): Remove the cgraph node if the elaboration procedure is empty.
	(Subprogram_Body_to_gnu): If a stub is attached to the subprogram, emit
	the former right after the latter.
	(start_stmt_group): Make global.
	(end_stmt_group): Likewise.
	(gnu_constraint_error_label_stack, gnu_storage_error_label_stack): New
	vars.
	(gnu_program_error_label_stack): Likewise.
	(gigi): Initialize them.
	(call_to_gnu, gnat_to_gnu, emit_check): Add new arg to build_call_raise.
	(gnat_to_gnu, N_{Push,Pop}_{Constraint,Storage,Program}_Error_Label):
	New cases.
	(push_exception_label_stack): New function.
	(takes_address): New function.

	* utils.c (struct language_function): Move to trans.c from here.
	(unchecked_convert): Do not wrap up integer constants in
	VIEW_CONVERT_EXPRs.
	(create_var_decl_1): Decouple TREE_CONSTANT from CONST_DECL. Prevent
	the latter for aggregate types, unexpected by later passes, and relax an
	arbitrary size constraint on the former.
	(create_field_decl): Use tree_int_cst_equal instead of operand_equal_p
	to compare the sizes.
	(convert_vms_descriptor): When converting to a fat pointer type, be
	prepared for a S descriptor at runtime in spite of a SB specification.
	(shift_unc_components_for_thin_pointers): New function.
	(write_record_type_debug_info): For variable-sized fields, cap the
	alignment of the pointer to the computed alignment.
	(finish_record_type): Change HAS_REP parameter into REP_LEVEL.
	If REP_LEVEL is 2, do not compute the sizes.
	(build_vms_descriptor): Adjust for new prototype of finish_record_type.
	(build_unc_object_type): Likewise.
	(declare_debug_type): New function.

        * ada-tree.def: USE_STMT: removed (not emitted anymore).

        * misc.c (gnat_expand_expr): Call to gnat_expand_stmt removed because
        no statement is expandable anymore.
        (gnat_init_gcc_eh): Do not initialize the DWARF-2 CFI machinery twice.
        (gnat_handle_option): Only allow flag_eliminate_debug_types to be set
        when the user requested it explicitely.
        (gnat_post_options): By default, set flag_eliminate_unused_debug_types
        to 0 for Ada.
        (get_alias_set): Return alias set 0 for a type if
        TYPE_UNIVERSAL_ALIASING_P is set on its main variant.

        * ada-tree.h: (TYPE_UNIVERSAL_ALIASING_P): New macro.
        (DECL_FUNCTION_STUB): New accessor macro.
        (SET_DECL_FUNCTION_STUB): New setter macro.

        * lang.opt (feliminate-unused-debug-types): Intercept this flag for Ada.

	* fe.h (Get_Local_Raise_Call_Entity, Get_RT_Exception_Entity): New
	declarations.

From-SVN: r125371

gcc/ada/ada-tree.def

@@ -80,6 +80,3 @@ DEFTREECODE (REGION_STMT, "region_stmt", tcc_statement, 3)
    handler itself, and HANDLER_STMT_BLOCK is the BLOCK node for this
    binding. */
 DEFTREECODE (HANDLER_STMT, "handler_stmt", tcc_statement, 3)
-
-/* A statement that emits a USE for its single operand.  */
-DEFTREECODE (USE_STMT, "use_expr", tcc_statement, 1)

gcc/ada/ada-tree.h

@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2006 Free Software Foundation, Inc.          *
+ *          Copyright (C) 1992-2007, 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- *
@@ -161,6 +161,9 @@ struct lang_type GTY(()) {tree t; };
    padding or alignment.  */
 #define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE))
 
+/* True if TYPE can alias any other types.  */
+#define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE)
+
 /* This field is only defined for FUNCTION_TYPE nodes. If the Ada
    subprogram contains no parameters passed by copy in/copy out then this
    field is 0. Otherwise it points to a list of nodes used to specify the
@@ -288,6 +291,13 @@ struct lang_type GTY(()) {tree t; };
 #define SET_DECL_RENAMED_OBJECT(NODE, X) \
   SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X)
 
+/* In a FUNCTION_DECL, points to the stub associated with the function
+   if any, otherwise 0.  */
+#define DECL_FUNCTION_STUB(NODE) \
+  GET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE))
+#define SET_DECL_FUNCTION_STUB(NODE, X) \
+  SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X)
+
 /* In a FIELD_DECL corresponding to a discriminant, contains the
    discriminant number.  */
 #define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))

gcc/ada/fe.h

@@ -100,6 +100,14 @@ extern Entity_Id             Error_Msg_Node_2;
 extern Uint                  Error_Msg_Uint_1;
 extern Uint                  Error_Msg_Uint_2;
 
+/* exp_ch11:  */
+
+#define Get_Local_Raise_Call_Entity exp_ch11__get_local_raise_call_entity
+#define Get_RT_Exception_Entity exp_ch11__get_rt_exception_entity
+
+extern Entity_Id Get_Local_Raise_Call_Entity (void);
+extern Entity_Id Get_RT_Exception_Entity (int);
+
 /* exp_code:  */
 
 #define Asm_Input_Constraint exp_code__asm_input_constraint

gcc/ada/gigi.h

@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2006, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2007, 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- *
@@ -51,6 +51,11 @@ extern bool must_pass_by_ref (tree gnu_type);
 /* Initialize DUMMY_NODE_TABLE.  */
 extern void init_dummy_type (void);
 
+/* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
+   GCC type corresponding to that entity.  GNAT_ENTITY is assumed to
+   refer to an Ada type.  */
+extern tree gnat_to_gnu_type (Entity_Id gnat_entity);
+
 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
    entity, this routine returns the equivalent GCC tree for that entity
    (an ..._DECL node) and associates the ..._DECL node with the input GNAT
@@ -73,10 +78,11 @@ extern tree gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
    FIELD_DECL.  */
 extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity);
 
-/* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
-   GCC type corresponding to that entity.  GNAT_ENTITY is assumed to
-   refer to an Ada type.  */
-extern tree gnat_to_gnu_type (Entity_Id gnat_entity);
+/* Wrap up compilation of T, a TYPE_DECL, possibly deferring it.  */
+extern void rest_of_type_decl_compilation (tree t);
+
+/* Start a new statement group chained to the previous group.  */
+extern void start_stmt_group (void);
 
 /* Add GNU_STMT to the current BLOCK_STMT node.  */
 extern void add_stmt (tree gnu_stmt);
@@ -84,6 +90,11 @@ extern void add_stmt (tree gnu_stmt);
 /* Similar, but set the location of GNU_STMT to that of GNAT_NODE.  */
 extern void add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node);
 
+/* Return code corresponding to the current code group.  It is normally
+   a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
+   BLOCK or cleanups were set.  */
+extern tree end_stmt_group (void);
+
 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK.  */
 extern void set_block_for_group (tree);
 
@@ -91,6 +102,18 @@ extern void set_block_for_group (tree);
    Get SLOC from GNAT_ENTITY.  */
 extern void add_decl_expr (tree gnu_decl, Entity_Id gnat_entity);
 
+/* Finalize any From_With_Type incomplete types.  We do this after processing
+   our compilation unit and after processing its spec, if this is a body.  */
+extern void finalize_from_with_types (void);
+
+/* Return the equivalent type to be used for GNAT_ENTITY, if it's a
+   kind of type (such E_Task_Type) that has a different type which Gigi
+   uses for its representation.  If the type does not have a special type
+   for its representation, return GNAT_ENTITY.  If a type is supposed to
+   exist, but does not, abort unless annotating types, in which case
+   return Empty.   If GNAT_ENTITY is Empty, return Empty.  */
+extern Entity_Id Gigi_Equivalent_Type (Entity_Id);
+
 /* Given GNAT_ENTITY, elaborate all expressions that are required to
    be elaborated at the point of its definition, but do nothing else.  */
 extern void elaborate_entity (Entity_Id gnat_entity);
@@ -108,9 +131,12 @@ extern tree get_unpadded_type (Entity_Id gnat_entity);
 /* Called when we need to protect a variable object using a save_expr.  */
 extern tree maybe_variable (tree gnu_operand);
 
-/* Create a record type that contains a field of TYPE with a starting bit
-   position so that it is aligned to ALIGN bits and is SIZE bytes long.  */
-extern tree make_aligning_type (tree type, int align, tree size);
+/* Create a record type that contains a SIZE bytes long field of TYPE with a
+    starting bit position so that it is aligned to ALIGN bits, and leaving at
+    least ROOM bytes free before the field.  BASE_ALIGN is the alignment the
+    record is guaranteed to get.  */
+extern tree make_aligning_type (tree type, unsigned int align, tree size,
+				unsigned int base_align, int room);
 
 /* Ensure that TYPE has SIZE and ALIGN.  Make and return a new padded type
    if needed.  We have already verified that SIZE and TYPE are large enough.
@@ -244,26 +270,19 @@ extern tree protect_multiple_eval (tree exp);
    binary and unary operations.  */
 extern void init_code_table (void);
 
+/* Return a label to branch to for the exception type in KIND or NULL_TREE
+   if none.  */
+extern tree get_exception_label (char);
+
 /* Current node being treated, in case gigi_abort or Check_Elaboration_Code
    called.  */
 extern Node_Id error_gnat_node;
 
-/* This is equivalent to stabilize_reference in GCC's tree.c, but we know how
-   to handle our new nodes and we take extra arguments.
-
-   FORCE says whether to force evaluation of everything,
-
-   SUCCESS we set to true unless we walk through something we don't
-   know how to stabilize, or through something which is not an lvalue
-   and LVALUES_ONLY is true, in which cases we set to false.  */
-extern tree maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
-				       bool *success);
-
-/* Wrapper around maybe_stabilize_reference, for common uses without
-   lvalue restrictions and without need to examine the success
-   indication.  */
-
-extern tree gnat_stabilize_reference (tree ref, bool force);
+/* This is equivalent to stabilize_reference in tree.c, but we know how to
+   handle our own nodes and we take extra arguments.  FORCE says whether to
+   force evaluation of everything.  We set SUCCESS to true unless we walk
+   through something we don't know how to stabilize.  */
+extern tree maybe_stabilize_reference (tree ref, bool force, bool *success);
 
 /* Highest number in the front-end node table.  */
 extern int max_gnat_nodes;
@@ -483,17 +502,23 @@ extern bool present_gnu_tree (Entity_Id gnat_entity);
 /* Initialize tables for above routines.  */
 extern void init_gnat_to_gnu (void);
 
-/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
-   nodes (FIELDLIST), finish constructing the record or union type.
-   If HAS_REP is true, this record has a rep clause; don't call
-   layout_type but merely set the size and alignment ourselves.
-   If DEFER_DEBUG is true, do not call the debugging routines
-   on this type; it will be done later. */
+/* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST,
+   finish constructing the record or union type.  If REP_LEVEL is zero, this
+   record has no representation clause and so will be entirely laid out here.
+   If REP_LEVEL is one, this record has a representation clause and has been
+   laid out already; only set the sizes and alignment.  If REP_LEVEL is two,
+   this record is derived from a parent record and thus inherits its layout;
+   only make a pass on the fields to finalize them.  If DO_NOT_FINALIZE is
+   true, the record type is expected to be modified afterwards so it will
+   not be sent to the back-end for finalization.  */
 extern void finish_record_type (tree record_type, tree fieldlist,
-                                bool has_rep, bool defer_debug);
+                                int rep_level, bool do_not_finalize);
 
-/*  Output the debug information associated to a record type.  */
-extern void write_record_type_debug_info (tree);
+/* Wrap up compilation of RECORD_TYPE, i.e. most notably output all
+   the debug information associated with it.  It need not be invoked
+   directly in most cases since finish_record_type takes care of doing
+   so, unless explicitly requested not to through DO_NOT_FINALIZE.  */
+extern void rest_of_record_type_compilation (tree record_type);
 
 /* Returns a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
    subprogram. If it is void_type_node, then we are dealing with a procedure,
@@ -515,8 +540,10 @@ extern tree create_subprog_type (tree return_type, tree param_decl_list,
 extern tree copy_type (tree type);
 
 /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
-   TYPE_INDEX_TYPE is INDEX.  */
-extern tree create_index_type (tree min, tree max, tree index);
+   TYPE_INDEX_TYPE is INDEX.  GNAT_NODE is used for the position of
+   the decl.  */
+extern tree create_index_type (tree min, tree max, tree index,
+			       Node_Id gnat_node);
 
 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
    string) and TYPE is a ..._TYPE node giving its data type.
@@ -623,10 +650,13 @@ extern tree build_template (tree template_type, tree array_type, tree expr);
    a constructor is made for the type.  GNAT_ENTITY is a gnat node used
    to print out an error message if the mechanism cannot be applied to
    an object of that type and also for the name.  */
-
 extern tree build_vms_descriptor (tree type, Mechanism_Type mech,
                                   Entity_Id gnat_entity);
 
+/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
+   and the GNAT node GNAT_SUBPROG.  */
+extern void build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog);
+
 /* Build a type to be used to represent an aliased object whose nominal
    type is an unconstrained array.  This consists of a RECORD_TYPE containing
    a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
@@ -641,6 +671,10 @@ extern tree build_unc_object_type (tree template_type, tree object_type,
 extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type,
 					    tree object_type, tree name);
 
+/* Shift the component offsets within an unconstrained object TYPE to make it
+   suitable for use as a designated type for thin pointers.  */
+extern void shift_unc_components_for_thin_pointers (tree type);
+
 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.  In
    the normal case this is just two adjustments, but we have more to do
    if NEW is an UNCONSTRAINED_ARRAY_TYPE.  */
@@ -731,8 +765,11 @@ extern tree build_call_0_expr (tree fundecl);
 
    GNAT_NODE is the gnat node conveying the source location for which the
    error should be signaled, or Empty in which case the error is signaled on
-   the current ref_file_name/input_line.  */
-extern tree build_call_raise (int msg, Node_Id gnat_node);
+   the current ref_file_name/input_line.
+
+   KIND says which kind of exception this is for
+    (N_Raise_{Constraint,Storage,Program}_Error).  */
+extern tree build_call_raise (int msg, Node_Id gnat_node, char kind);
 
 /* Return a CONSTRUCTOR of TYPE whose list is LIST.  This is not the
    same as build_constructor in the language-independent tree.c.  */

gcc/ada/lang.opt

@@ -69,6 +69,12 @@ nostdinc
 Ada RejectNegative
 ; Don't look for source files
 
+feliminate-unused-debug-types
+Ada
+; Effect documented for C - intercepted for Ada to force the associated flag
+; not to be set by default, as it currently eliminates unreferenced parallel
+; types we need for encoding descriptions to the debugger.
+
 nostdlib
 Ada
 ; Don't look for object files

gcc/ada/misc.c

@@ -6,7 +6,7 @@
  *                                                                          *
  *                           C Implementation File                          *
  *                                                                          *
- *          Copyright (C) 1992-2006, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2007, 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- *
@@ -302,6 +302,14 @@ gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
       gnat_argc++;
       break;
 
+    case OPT_feliminate_unused_debug_types:
+      /* We arrange for post_option to be able to only set the corresponding
+         flag to 1 when explicitely requested by the user.  We expect the
+         default flag value to be either 0 or positive, and expose a positive
+         -f as a negative value to post_option.  */
+      flag_eliminate_unused_debug_types = -value;
+      break;
+
     case OPT_fRTS_:
       gnat_argv[gnat_argc] = xstrdup ("-fRTS");
       gnat_argc++;
@@ -362,6 +370,14 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
   if (flag_inline_functions)
     flag_inline_trees = 2;
 
+  /* Force eliminate_unused_debug_types to 0 unless an explicit positive
+     -f has been passed.  This forces the default to 0 for Ada, which might
+     differ from the common default.  */
+  if (flag_eliminate_unused_debug_types < 0)
+    flag_eliminate_unused_debug_types = 1;
+  else
+    flag_eliminate_unused_debug_types = 0;
+
   /* The structural alias analysis machinery essentially assumes that
      everything is addressable (modulo bit-fields) by disregarding
      the TYPE_NONALIASED_COMPONENT and DECL_NONADDRESSABLE_P macros.  */
@@ -484,6 +500,11 @@ gnat_compute_largest_alignment (void)
 void
 gnat_init_gcc_eh (void)
 {
+#ifdef DWARF2_UNWIND_INFO
+  /* lang_dependent_init already called dwarf2out_frame_init if true.  */
+  int dwarf2out_frame_initialized = dwarf2out_do_frame ();
+#endif
+
   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
      though. This could for instance lead to the emission of tables with
      references to symbols (such as the Ada eh personality routine) within
@@ -517,7 +538,7 @@ gnat_init_gcc_eh (void)
 
   init_eh ();
 #ifdef DWARF2_UNWIND_INFO
-  if (dwarf2out_do_frame ())
+  if (!dwarf2out_frame_initialized && dwarf2out_do_frame ())
     dwarf2out_frame_init ();
 #endif
 }
@@ -633,13 +654,6 @@ gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode,
   tree type = TREE_TYPE (exp);
   tree new;
 
-  /* If this is a statement, call the expansion routine for statements.  */
-  if (IS_STMT (exp))
-    {
-      gnat_expand_stmt (exp);
-      return const0_rtx;
-    }
-
   /* Update EXP to be the new expression to expand.  */
   switch (TREE_CODE (exp))
     {
@@ -746,6 +760,10 @@ gnat_get_alias_set (tree type)
     return
       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 
+  /* If the type can alias any other types, return the alias set 0.  */
+  else if (TYPE_P (type)
+	   && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
+    return 0;
 
   return -1;
 }

gcc/ada/trans.c

@@ -82,6 +82,31 @@ const char *ref_filename;
    types with representation information. */
 bool type_annotate_only;
 
+/* 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 parm_attr GTY (())
+{
+  int id; /* GTY doesn't like Entity_Id.  */
+  int dim;
+  tree first;
+  tree last;
+  tree length;
+};
+
+typedef struct parm_attr *parm_attr;
+
+DEF_VEC_P(parm_attr);
+DEF_VEC_ALLOC_P(parm_attr,gc);
+
+struct language_function GTY(())
+{
+  VEC(parm_attr,gc) *parm_attr_cache;
+};
+
+#define f_parm_attr_cache \
+  DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
+
 /* 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
@@ -137,6 +162,11 @@ static GTY(()) tree gnu_loop_label_stack;
    TREE_VALUE of each entry is the label at the end of the switch.  */
 static GTY(()) tree gnu_switch_label_stack;
 
+/* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label.  */
+static GTY(()) tree gnu_constraint_error_label_stack;
+static GTY(()) tree gnu_storage_error_label_stack;
+static GTY(()) tree 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];
 
@@ -146,12 +176,11 @@ Node_Id error_gnat_node;
 static void Compilation_Unit_to_gnu (Node_Id);
 static void record_code_position (Node_Id);
 static void insert_code_for (Node_Id);
-static void start_stmt_group (void);
-static void add_cleanup (tree);
+static void add_cleanup (tree, Node_Id);
 static tree mark_visited (tree *, int *, void *);
 static tree unshare_save_expr (tree *, int *, void *);
-static tree end_stmt_group (void);
 static void add_stmt_list (List_Id);
+static void push_exception_label_stack (tree *, Entity_Id);
 static tree build_stmt_group (List_Id, bool);
 static void push_stack (tree *, tree, tree);
 static void pop_stack (tree *);
@@ -169,9 +198,10 @@ 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 tree gnat_stabilize_reference (tree, bool);
 static tree gnat_stabilize_reference_1 (tree, bool);
 static void annotate_with_node (tree, Node_Id);
-
+static int takes_address (Node_Id, tree);
 
 /* This is the main program of the back-end.  It sets up all the table
    structures and then generates code.  */
@@ -222,6 +252,10 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
 		 false);
 
   gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
+  gnu_constraint_error_label_stack
+    = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
+  gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
+  gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
 
   gnu_standard_long_long_float
     = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
@@ -274,7 +308,10 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
 
       /* If there are no statements, there is no elaboration code.  */
       if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
+	{
 	  Set_Has_No_Elaboration_Code (info->gnat_node, 1);
+	  cgraph_remove_node (cgraph_node (info->elab_proc));
+	}
       else
 	{
 	  /* Otherwise, compile the function.  Note that we'll be gimplifying
@@ -299,6 +336,54 @@ gnat_init_stmt_group (void)
     set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
 }
 
+/* Returns a positive value if GNAT_NODE denotes an address construction
+   for an operand of OPERAND_TYPE, zero otherwise.  This is int instead
+   of bool to facilitate usage in non purely binary logic contexts.  */
+
+static int
+takes_address (Node_Id gnat_node, tree operand_type)
+{
+  switch (Nkind (gnat_node))
+    {
+    case N_Reference:
+      return 1;
+
+    case N_Attribute_Reference:
+      {
+	unsigned char id = Get_Attribute_Id (Attribute_Name (gnat_node));
+	return id == Attr_Address
+	       || id == Attr_Access
+	       || id == Attr_Unchecked_Access
+	       || id == Attr_Unrestricted_Access;
+      }
+
+    case N_Function_Call:
+    case N_Procedure_Call_Statement:
+      return must_pass_by_ref (operand_type)
+	     || default_pass_by_ref (operand_type);
+
+    case N_Indexed_Component:
+      {
+	Node_Id gnat_temp;
+	/* ??? Consider that referencing an indexed component with a
+	   non-constant index forces the whole aggregate to memory.
+	   Note that N_Integer_Literal is conservative, any static
+	   expression in the RM sense could probably be accepted.  */
+	for (gnat_temp = First (Expressions (gnat_node));
+	     Present (gnat_temp);
+	     gnat_temp = Next (gnat_temp))
+	  if (Nkind (gnat_temp) != N_Integer_Literal)
+	    return 1;
+	return takes_address (Parent (gnat_node), operand_type);
+      }
+
+    default:
+      return 0;
+    }
+
+  gcc_unreachable ();
+}
+
 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
    to a GCC tree, which is returned.  GNU_RESULT_TYPE_P is a pointer to
    where we should place the result type.  */
@@ -310,6 +395,16 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
   tree gnu_result;
   Node_Id gnat_temp, gnat_temp_type;
 
+  /* Whether the parent of gnat_node is taking its address.  Needed in
+     specific circumstances only, so evaluated lazily. < 0 means unknown,
+     > 0 means known true, 0 means known false.  */
+  int parent_takes_address = -1;
+
+  /* If GNAT_NODE is a constant, whether we should use the initialization
+     value instead of the constant entity, typically for scalars with an
+     address clause when the parent is not taking the address.  */
+  bool use_constant_initializer = false;
+
   /* If the Etype of this node does not equal the Etype of the Entity,
      something is wrong with the entity map, probably in generic
      instantiation. However, this does not apply to types. Since we sometime
@@ -351,20 +446,17 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
      in particular if it is a derived type  */
   if (Is_Private_Type (gnat_temp_type)
       && Has_Unknown_Discriminants (gnat_temp_type)
-      && Present (Full_View (gnat_temp))
-      && !Is_Type (gnat_temp))
+      && Ekind (gnat_temp) == E_Constant
+      && Present (Full_View (gnat_temp)))
     {
       gnat_temp = Full_View (gnat_temp);
       gnat_temp_type = Etype (gnat_temp);
-      gnu_result_type = get_unpadded_type (gnat_temp_type);
     }
   else
     {
-      /* Expand the type of this identifier first, in case it is an enumeral
-	 literal, which only get made when the type is expanded.  There is no
-	 order-of-elaboration issue here.  We want to use the Actual_Subtype if
-	 it has already been elaborated, otherwise the Etype.  Avoid using
-	 Actual_Subtype for packed arrays to simplify things.  */
+      /* We want to use the Actual_Subtype if it has already been elaborated,
+	 otherwise the Etype.  Avoid using Actual_Subtype for packed arrays to
+	 simplify things.  */
       if ((Ekind (gnat_temp) == E_Constant
 	   || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
 	  && !(Is_Array_Type (Etype (gnat_temp))
@@ -374,10 +466,40 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 	gnat_temp_type = Actual_Subtype (gnat_temp);
       else
 	gnat_temp_type = Etype (gnat_node);
+    }
 
+  /* Expand the type of this identifier first, in case it is an enumeral
+     literal, which only get made when the type is expanded.  There is no
+     order-of-elaboration issue here.  */
   gnu_result_type = get_unpadded_type (gnat_temp_type);
+
+  /* If this is a non-imported scalar constant with an address clause,
+     retrieve the value instead of a pointer to be dereferenced, unless the
+     parent is taking the address.  This is generally more efficient and
+     actually required if this is a static expression because it might be used
+     in a context where a dereference is inappropriate, such as a case
+     statement alternative or a record discriminant.  There is no possible
+     volatile-ness shortciruit here since Volatile constants must be imported
+     per C.6. */
+  if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type)
+      && !Is_Imported (gnat_temp)
+      && Present (Address_Clause (gnat_temp)))
+    {
+      parent_takes_address
+	= takes_address (Parent (gnat_node), gnu_result_type);
+      use_constant_initializer = !parent_takes_address;
     }
 
+  if (use_constant_initializer)
+    {
+      /* If this is a deferred constant, the initializer is attached to the
+	 the full view.  */
+      if (Present (Full_View (gnat_temp)))
+	gnat_temp = Full_View (gnat_temp);
+
+      gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
+    }
+  else
     gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
 
   /* If we are in an exception handler, force this variable into memory to
@@ -404,8 +526,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
   /* Some objects (such as parameters passed by reference, globals of
      variable size, and renamed objects) actually represent the address
      of the object.  In that case, we must do the dereference.  Likewise,
-     deal with parameters to foreign convention subprograms.  Call fold
-     here since GNU_RESULT may be a CONST_DECL.  */
+     deal with parameters to foreign convention subprograms.  */
   if (DECL_P (gnu_result)
       && (DECL_BY_REF_P (gnu_result)
 	  || (TREE_CODE (gnu_result) == PARM_DECL
@@ -429,9 +550,15 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 	       && (! DECL_RENAMING_GLOBAL_P (gnu_result)
 		   || global_bindings_p ()))
 	gnu_result = renamed_obj;
-      else
+
+      /* Return the underlying CST for a CONST_DECL like a few lines below,
+	 after dereferencing in this case.  */
+      else if (TREE_CODE (gnu_result) == CONST_DECL)
 	gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
-				     fold (gnu_result));
+				     DECL_INITIAL (gnu_result));
+
+      else
+	gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
 
       TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
     }
@@ -448,23 +575,26 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 	gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
     }
 
-  /* We always want to return the underlying INTEGER_CST for an enumeration
-     literal to avoid the need to call fold in lots of places.  But don't do
-     this is the parent will be taking the address of this object.  */
-  if (TREE_CODE (gnu_result) == CONST_DECL)
-    {
-      gnat_temp = Parent (gnat_node);
-      if (!DECL_CONST_CORRESPONDING_VAR (gnu_result)
-	  || (Nkind (gnat_temp) != N_Reference
-	      && !(Nkind (gnat_temp) == N_Attribute_Reference
-		   && ((Get_Attribute_Id (Attribute_Name (gnat_temp))
-			== Attr_Address)
-		       || (Get_Attribute_Id (Attribute_Name (gnat_temp))
-			   == Attr_Access)
-		       || (Get_Attribute_Id (Attribute_Name (gnat_temp))
-			    == Attr_Unchecked_Access)
-		       || (Get_Attribute_Id (Attribute_Name (gnat_temp))
-			   == Attr_Unrestricted_Access)))))
+  /* If we have a constant declaration and it's initializer at hand, return
+     the latter to avoid the need to call fold in lots of places and the need
+     of elaboration code if this Id is used as an initializer itself.  Don't
+     do this if the parent will be taking the address of this object and
+     there is a corresponding variable to take the address of.  */
+  if (TREE_CONSTANT (gnu_result)
+      && DECL_P (gnu_result) && DECL_INITIAL (gnu_result))
+    {
+      tree object
+	= (TREE_CODE (gnu_result) == CONST_DECL
+	   ? DECL_CONST_CORRESPONDING_VAR (gnu_result) : gnu_result);
+
+      /* If there is a corresponding variable, we only want to return the CST
+	 value if the parent is not taking the address.  Evaluate this now if
+	 we have not already done so.  */
+      if (object && parent_takes_address < 0)
+	parent_takes_address
+	  = takes_address (Parent (gnat_node), gnu_result_type);
+
+      if (!object || !parent_takes_address)
 	gnu_result = DECL_INITIAL (gnu_result);
     }
 
@@ -497,12 +627,47 @@ Pragma_to_gnu (Node_Id gnat_node)
 	   Present (gnat_temp);
 	   gnat_temp = Next (gnat_temp))
 	{
-	  tree gnu_expr = gnat_to_gnu (Expression (gnat_temp));
+	  Node_Id gnat_expr = Expression (gnat_temp);
+	  tree gnu_expr = gnat_to_gnu (gnat_expr);
+	  int use_address;
+	  enum machine_mode mode;
+	  tree asm_constraint = NULL_TREE;
+#ifdef ASM_COMMENT_START
+	  char *comment;
+#endif
 
 	  if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
 	    gnu_expr = TREE_OPERAND (gnu_expr, 0);
 
-	  gnu_expr = build1 (USE_STMT, void_type_node, gnu_expr);
+	  /* Use the value only if it fits into a normal register,
+	     otherwise use the address.  */
+	  mode = TYPE_MODE (TREE_TYPE (gnu_expr));
+	  use_address = ((GET_MODE_CLASS (mode) != MODE_INT
+			  && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
+			 || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
+
+	  if (use_address)
+	    gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
+
+#ifdef ASM_COMMENT_START
+	  comment = concat (ASM_COMMENT_START,
+			    " inspection point: ",
+			    Get_Name_String (Chars (gnat_expr)),
+			    use_address ? " address" : "",
+			    " is in %0",
+			    NULL);
+	  asm_constraint = build_string (strlen (comment), comment);
+	  free (comment);
+#endif
+	  gnu_expr = build4 (ASM_EXPR, void_type_node,
+			     asm_constraint,
+			     NULL_TREE,
+			     tree_cons
+			     (build_tree_list (NULL_TREE,
+					       build_string (1, "g")),
+			      gnu_expr, NULL_TREE),
+			     NULL_TREE);
+	  ASM_VOLATILE_P (gnu_expr) = 1;
 	  annotate_with_node (gnu_expr, gnat_node);
 	  append_to_statement_list (gnu_expr, &gnu_result);
 	}
@@ -839,11 +1004,18 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
       {
 	int Dimension = (Present (Expressions (gnat_node))
 			 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
-			 : 1);
+			 : 1), i;
+	struct parm_attr *pa = NULL;
+	Entity_Id gnat_param = Empty;
 
 	/* Make sure any implicit dereference gets done.  */
 	gnu_prefix = maybe_implicit_deref (gnu_prefix);
 	gnu_prefix = maybe_unconstrained_array (gnu_prefix);
+	/* We treat unconstrained array IN parameters specially.  */
+	if (Nkind (Prefix (gnat_node)) == N_Identifier
+	    && !Is_Constrained (Etype (Prefix (gnat_node)))
+	    && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
+	  gnat_param = Entity (Prefix (gnat_node));
 	gnu_type = TREE_TYPE (gnu_prefix);
 	prefix_unused = true;
 	gnu_result_type = get_unpadded_type (Etype (gnat_node));
@@ -862,20 +1034,64 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	    Dimension = ndim + 1 - Dimension;
 	  }
 
-	for (; Dimension > 1; Dimension--)
+	for (i = 1; i < Dimension; i++)
 	  gnu_type = TREE_TYPE (gnu_type);
 
 	gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
+
+	/* When not optimizing, look up the slot associated with the parameter
+	   and the dimension in the cache and create a new one on failure.  */
+	if (!optimize && Present (gnat_param))
+	  {
+	    for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
+	      if (pa->id == gnat_param && pa->dim == Dimension)
+		break;
+
+	    if (!pa)
+	      {
+		pa = GGC_CNEW (struct parm_attr);
+		pa->id = gnat_param;
+		pa->dim = Dimension;
+		VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
+	      }
+	  }
+
+	/* Return the cached expression or build a new one.  */
 	if (attribute == Attr_First)
+	  {
+	    if (pa && pa->first)
+	      {
+		gnu_result = pa->first;
+		break;
+	      }
+
 	    gnu_result
 	      = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
+	  }
+
 	else if (attribute == Attr_Last)
+	  {
+	    if (pa && pa->last)
+	      {
+		gnu_result = pa->last;
+		break;
+	      }
+
 	    gnu_result
 	      = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
-	else
-	  /* 'Length or 'Range_Length.  */
+	  }
+
+	else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
 	  {
-	    tree gnu_compute_type
+	    tree gnu_compute_type;
+
+	    if (pa && pa->length)
+	      {
+		gnu_result = pa->length;
+		break;
+	      }
+
+	    gnu_compute_type
 	      = get_signed_or_unsigned_type (0,
 					     get_base_type (gnu_result_type));
 
@@ -901,6 +1117,23 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	   an unconstrained array type.  */
 	gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
 						     gnu_prefix);
+
+	/* Cache the expression we have just computed.  Since we want to do it
+	   at runtime, we force the use of a SAVE_EXPR and let the gimplifier
+	   create the temporary.  */
+	if (pa)
+	  {
+	    gnu_result
+	      = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
+	    TREE_SIDE_EFFECTS (gnu_result) = 1;
+	    TREE_INVARIANT (gnu_result) = 1;
+	    if (attribute == Attr_First)
+	      pa->first = gnu_result;
+	    else if (attribute == Attr_Last)
+	      pa->last = gnu_result;
+	    else
+	      pa->length = gnu_result;
+	  }
 	break;
       }
 
@@ -1181,29 +1414,6 @@ Case_Statement_to_gnu (Node_Id gnat_node)
 		  gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
 		  break;
 		}
-	      /* Static values are handled by the next case to which we'll
-		 fallthrough.  If this is a constant with an address clause
-		 attached, we need to get to the initialization expression
-		 first, as the GCC tree for the entity might happen to be an
-		 INDIRECT_REF otherwise.  */
-	      else if (Ekind (Entity (gnat_choice)) == E_Constant
-		       && Present (Address_Clause (Entity (gnat_choice))))
-		{
-		  /* We might have a deferred constant with an address clause
-		     on either the incomplete or the full view.  While the
-		     Address_Clause is always attached to the visible entity,
-		     as tested above, the static value is the Expression
-		     attached to the the declaration of the entity or of its
-		     full view if any.  */
-
-		  Entity_Id gnat_constant = Entity (gnat_choice);
-
-		  if (Present (Full_View (gnat_constant)))
-		    gnat_constant = Full_View (gnat_constant);
-
-		  gnat_choice
-		    = Expression (Declaration_Node (gnat_constant));
-		}
 
 	      /* ... fall through ... */
 
@@ -1453,9 +1663,6 @@ establish_gnat_vms_condition_handler (void)
 static void
 Subprogram_Body_to_gnu (Node_Id gnat_node)
 {
-  /* Save debug output mode in case it is reset.  */
-  enum debug_info_type save_write_symbols = write_symbols;
-  const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks;
   /* Defining identifier of a parameter to the subprogram.  */
   Entity_Id gnat_param;
   /* The defining identifier for the subprogram body. Note that if a
@@ -1471,6 +1678,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
   tree gnu_subprog_type;
   tree gnu_cico_list;
   tree gnu_result;
+  VEC(parm_attr,gc) *cache;
 
   /* If this is a generic object or if it has been eliminated,
      ignore it.  */
@@ -1479,14 +1687,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
       || Is_Eliminated (gnat_subprog_id))
     return;
 
-  /* If debug information is suppressed for the subprogram, turn debug
-     mode off for the duration of processing.  */
-  if (!Needs_Debug_Info (gnat_subprog_id))
-    {
-      write_symbols = NO_DEBUG;
-      debug_hooks = &do_nothing_debug_hooks;
-    }
-
   /* If this subprogram acts as its own spec, define it.  Otherwise, just get
      the already-elaborated tree node.  However, if this subprogram had its
      elaboration deferred, we will already have made a tree node for it.  So
@@ -1500,11 +1700,19 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
 
   gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
 
+  /* Propagate the debug mode.  */
+  if (!Needs_Debug_Info (gnat_subprog_id))
+    DECL_IGNORED_P (gnu_subprog_decl) = 1;
+
   /* Set the line number in the decl to correspond to that of the body so that
-     the line number notes are written
-     correctly.  */
+     the line number notes are written correctly.  */
   Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
 
+  /* Initialize the information structure for the function.  */
+  allocate_struct_function (gnu_subprog_decl);
+  DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
+    = GGC_CNEW (struct language_function);
+
   begin_subprog_body (gnu_subprog_decl);
   gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
 
@@ -1540,7 +1748,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
 		     gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
       }
 
-
   /* On VMS, establish our condition handler to possibly turn a condition into
      the corresponding exception if the subprogram has a foreign convention or
      is exported.
@@ -1549,9 +1756,9 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
      we must turn a condition into the corresponding exception even if there
      is no applicable Ada handler, and need at least one condition handler per
      possible call chain involving GNAT code.  OTOH, establishing the handler
-     has a cost so we want to minimize the number of subprograms into which this
-     happens.  The foreign or exported condition is expected to satisfy all
-     the constraints.  */
+     has a cost so we want to minimize the number of subprograms into which
+     this happens.  The foreign or exported condition is expected to satisfy
+     all the constraints.  */
   if (TARGET_ABI_OPEN_VMS
       && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node)))
     establish_gnat_vms_condition_handler ();
@@ -1564,6 +1771,30 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
   gnat_poplevel ();
   gnu_result = end_stmt_group ();
 
+  /* If we populated the parameter attributes cache, we need to make sure
+     that the cached expressions are evaluated on all possible paths.  */
+  cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
+  if (cache)
+    {
+      struct parm_attr *pa;
+      int i;
+
+      start_stmt_group ();
+
+      for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
+	{
+	  if (pa->first)
+	    add_stmt (pa->first);
+	  if (pa->last)
+	    add_stmt (pa->last);
+	  if (pa->length)
+	    add_stmt (pa->length);
+	}
+
+      add_stmt (gnu_result);
+      gnu_result = end_stmt_group ();
+    }
+
   /* If we made a special return label, we need to make a block that contains
      the definition of that label and the copying to the return value.  That
      block first contains the function, then the label and copy statement.  */
@@ -1588,7 +1819,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
 	gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
 
       add_stmt_with_node
-	(build_return_expr (DECL_RESULT (current_function_decl), gnu_retval),
+	(build_return_expr (DECL_RESULT (gnu_subprog_decl), gnu_retval),
 	 gnat_node);
       gnat_poplevel ();
       gnu_result = end_stmt_group ();
@@ -1596,14 +1827,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
 
   pop_stack (&gnu_return_label_stack);
 
-  /* Initialize the information node for the function and set the
-     end location.  */
-  allocate_struct_function (current_function_decl);
+  /* Set the end location.  */
   Sloc_to_locus
     ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
       ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
       : Sloc (gnat_node)),
-     &cfun->function_end_locus);
+     &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
 
   end_subprog_body (gnu_result);
 
@@ -1615,9 +1844,10 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
     if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
       save_gnu_tree (gnat_param, NULL_TREE, false);
 
+  if (DECL_FUNCTION_STUB (gnu_subprog_decl))
+    build_function_stub (gnu_subprog_decl, gnat_subprog_id);
+
   mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
-  write_symbols = save_write_symbols;
-  debug_hooks = save_debug_hooks;
 }
 
 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
@@ -1671,7 +1901,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
 
       {
 	tree call_expr
-	  = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node);
+	  = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node,
+			      N_Raise_Program_Error);
 
 	if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
 	  {
@@ -2271,14 +2502,16 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
 
       /* When we exit this block, restore the saved value.  */
-      add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
+      add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
+		   End_Label (gnat_node));
     }
 
   /* If we are to call a function when exiting this block, add a cleanup
      to the binding level we made above.  Note that add_cleanup is FIFO
      so we must register this cleanup after the EH cleanup just above.  */
   if (at_end)
-    add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))));
+    add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
+		 End_Label (gnat_node));
 
   /* Now build the tree for the declarations and statements inside this block.
      If this is SJLJ, set our jmp_buf as the current buffer.  */
@@ -2581,7 +2814,9 @@ Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
   add_stmt_with_node (build_call_1_expr (begin_handler_decl,
 					 gnu_incoming_exc_ptr),
 		      gnat_node);
-  add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr));
+  /* ??? We don't seem to have an End_Label at hand to set the location.  */
+  add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
+	       Empty);
   add_stmt_list (Statements (gnat_node));
   gnat_poplevel ();
 
@@ -2618,7 +2853,10 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
   if (Nkind (Unit (gnat_node)) == N_Package_Body
       || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
 	      && !Acts_As_Spec (gnat_node)))
+    {
       add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
+      finalize_from_with_types ();
+    }
 
   process_inlined_subprograms (gnat_node);
 
@@ -2639,6 +2877,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
   /* Process any pragmas and actions following the unit.  */
   add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
   add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
+  finalize_from_with_types ();
 
   /* Save away what we've made so far and record this potential elaboration
      procedure.  */
@@ -2695,7 +2934,8 @@ gnat_to_gnu (Node_Id gnat_node)
       && Nkind (gnat_node) != N_Identifier
       && !Compile_Time_Known_Value (gnat_node))
     return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
-		   build_call_raise (CE_Range_Check_Failed, gnat_node));
+		   build_call_raise (CE_Range_Check_Failed, gnat_node,
+				     N_Raise_Constraint_Error));
 
   /* If this is a Statement and we are at top level, it must be part of the
      elaboration procedure, so mark us as being in that procedure and push our
@@ -3232,6 +3472,19 @@ gnat_to_gnu (Node_Id gnat_node)
 		   NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL,
 		   gnat_node));
 
+	/* Check for 'Address of a subprogram or function that has
+	   a Freeze_Node and whose saved tree is an ADDR_EXPR.  If we have
+	   such, return that ADDR_EXPR.  */
+	if (attribute == Attr_Address
+	    && Nkind (Prefix (gnat_node)) == N_Identifier
+	    && (Ekind (Entity (Prefix (gnat_node))) == E_Function
+		|| Ekind (Entity (Prefix (gnat_node))) == E_Procedure)
+	    && Present (Freeze_Node (Entity (Prefix (gnat_node))))
+	    && present_gnu_tree (Entity (Prefix (gnat_node)))
+	    && (TREE_CODE (get_gnu_tree (Entity (Prefix (gnat_node))))
+		== TREE_LIST))
+	  return TREE_PURPOSE (get_gnu_tree (Entity (Prefix (gnat_node))));
+
 	gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute);
       }
       break;
@@ -3649,7 +3902,8 @@ gnat_to_gnu (Node_Id gnat_node)
 	 Storage_Error: execution shouldn't have gotten here anyway.  */
       if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
 	   && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
-	gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node);
+	gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
+				       N_Raise_Storage_Error);
       else if (Nkind (Expression (gnat_node)) == N_Function_Call
 	       && !Do_Range_Check (Expression (gnat_node)))
 	gnu_result = call_to_gnu (Expression (gnat_node),
@@ -3876,11 +4130,23 @@ gnat_to_gnu (Node_Id gnat_node)
       /* Unless there is a freeze node, declare the subprogram.  We consider
 	 this a "definition" even though we're not generating code for
 	 the subprogram because we will be making the corresponding GCC
-	 node here.  */
-
-      if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
+	 node here.  If there is a freeze node, make a dummy ADDR_EXPR
+	 so we can take the address of this subprogram before its freeze
+	 point; we'll fill in the ADDR_EXPR later.  Put that ADDR_EXPR
+	 into a TREE_LIST that contains space for the value specified
+	 in an Address clause.  */
+      if (Freeze_Node (Defining_Entity (Specification (gnat_node))))
+	save_gnu_tree (Defining_Entity (Specification (gnat_node)),
+		       tree_cons (build1 (ADDR_EXPR,
+					  build_pointer_type
+					  (make_node (FUNCTION_TYPE)),
+					  NULL_TREE),
+				  NULL_TREE, NULL_TREE),
+		       true);
+      else
 	gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
 			    NULL_TREE, 1);
+
       gnu_result = alloc_stmt_list ();
       break;
 
@@ -4042,6 +4308,36 @@ gnat_to_gnu (Node_Id gnat_node)
 
       break;
 
+    case N_Push_Constraint_Error_Label:
+      push_exception_label_stack (&gnu_constraint_error_label_stack,
+				  Exception_Label (gnat_node));
+      break;
+
+    case N_Push_Storage_Error_Label:
+      push_exception_label_stack (&gnu_storage_error_label_stack,
+				  Exception_Label (gnat_node));
+      break;
+
+    case N_Push_Program_Error_Label:
+      push_exception_label_stack (&gnu_program_error_label_stack,
+				  Exception_Label (gnat_node));
+      break;
+
+    case N_Pop_Constraint_Error_Label:
+      gnu_constraint_error_label_stack
+	= TREE_CHAIN (gnu_constraint_error_label_stack);
+      break;
+
+    case N_Pop_Storage_Error_Label:
+      gnu_storage_error_label_stack
+	= TREE_CHAIN (gnu_storage_error_label_stack);
+      break;
+
+    case N_Pop_Program_Error_Label:
+      gnu_program_error_label_stack
+	= TREE_CHAIN (gnu_program_error_label_stack);
+      break;
+
     /*******************************/
     /* Chapter 12: Generic Units:  */
     /*******************************/
@@ -4077,7 +4373,13 @@ gnat_to_gnu (Node_Id gnat_node)
 
       /* Get the value to use as the address and save it as the
 	 equivalent for GNAT_TEMP.  When the object is frozen,
-	 gnat_to_gnu_entity will do the right thing. */
+	 gnat_to_gnu_entity will do the right thing. We have to handle
+	 subprograms differently here.  */
+      if (Ekind (Entity (Name (gnat_node))) == E_Procedure
+	  || Ekind (Entity (Name (gnat_node))) == E_Function)
+	TREE_VALUE (get_gnu_tree (Entity (Name (gnat_node))))
+	  = gnat_to_gnu (Expression (gnat_node));
+      else
 	save_gnu_tree (Entity (Name (gnat_node)),
 		       gnat_to_gnu (Expression (gnat_node)), true);
       break;
@@ -4295,7 +4597,8 @@ gnat_to_gnu (Node_Id gnat_node)
 
       gnu_result_type = get_unpadded_type (Etype (gnat_node));
       gnu_result
-	= build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node);
+	= build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node,
+			    Nkind (gnat_node));
 
       /* If the type is VOID, this is a statement, so we need to
 	 generate the code for the call.  Handle a Condition, if there
@@ -4387,10 +4690,12 @@ gnat_to_gnu (Node_Id gnat_node)
       current_function_decl = NULL_TREE;
     }
 
-  /* Set the location information into the result.  Note that we may have
+  /* Set the location information on the result if it is a real expression.
+     References can be reused for multiple GNAT nodes and they would get
+     the location information of their last use.  Note that we may have
      no result if we tried to build a CALL_EXPR node to a procedure with
      no side-effects and optimization is enabled.  */
-  if (gnu_result && EXPR_P (gnu_result))
+  if (gnu_result && EXPR_P (gnu_result) && !REFERENCE_CLASS_P (gnu_result))
     annotate_with_node (gnu_result, gnat_node);
 
   /* If we're supposed to return something of void_type, it means we have
@@ -4406,7 +4711,8 @@ gnat_to_gnu (Node_Id gnat_node)
 
       gnu_result
 	= build1 (NULL_EXPR, gnu_result_type,
-		  build_call_raise (CE_Overflow_Check_Failed, gnat_node));
+		  build_call_raise (CE_Overflow_Check_Failed, gnat_node,
+				    N_Raise_Constraint_Error));
     }
 
   /* If our result has side-effects and is of an unconstrained type,
@@ -4511,6 +4817,20 @@ gnat_to_gnu (Node_Id gnat_node)
   return gnu_result;
 }
 
+/* Subroutine of above to push the exception label stack.  GNU_STACK is
+   a pointer to the stack to update and GNAT_LABEL, if present, is the
+   label to push onto the stack.  */
+
+static void
+push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label)
+{
+  tree gnu_label = (Present (gnat_label)
+		    ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
+		    : NULL_TREE);
+
+  *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack);
+}
+
 /* Record the current code position in GNAT_NODE.  */
 
 static void
@@ -4533,7 +4853,7 @@ insert_code_for (Node_Id gnat_node)
 
 /* Start a new statement group chained to the previous group.  */
 
-static void
+void
 start_stmt_group (void)
 {
   struct stmt_group *group = stmt_group_free_list;
@@ -4672,11 +4992,14 @@ unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
   return NULL_TREE;
 }
 
-/* Add GNU_CLEANUP, a cleanup action, to the current code group.  */
+/* Add GNU_CLEANUP, a cleanup action, to the current code group and
+   set its location to that of GNAT_NODE if present.  */
 
 static void
-add_cleanup (tree gnu_cleanup)
+add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
 {
+  if (Present (gnat_node))
+    annotate_with_node (gnu_cleanup, gnat_node);
   append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
 }
 
@@ -4693,7 +5016,7 @@ set_block_for_group (tree gnu_block)
    a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
    BLOCK or cleanups were set.  */
 
-static tree
+tree
 end_stmt_group (void)
 {
   struct stmt_group *group = current_stmt_group;
@@ -4784,36 +5107,6 @@ pop_stack (tree *gnu_stack_ptr)
   gnu_stack_free_list = gnu_node;
 }
 
-/* GNU_STMT is a statement.  We generate code for that statement.  */
-
-void
-gnat_expand_stmt (tree gnu_stmt)
-{
-#if 0
-  tree gnu_elmt, gnu_elmt_2;
-#endif
-
-  switch (TREE_CODE (gnu_stmt))
-    {
-#if 0
-    case USE_STMT:
-      /* First write a volatile ASM_INPUT to prevent anything from being
-	 moved.  */
-      gnu_elmt = gen_rtx_ASM_INPUT (VOIDmode, "");
-      MEM_VOLATILE_P (gnu_elmt) = 1;
-      emit_insn (gnu_elmt);
-
-      gnu_elmt = expand_expr (TREE_OPERAND (gnu_stmt, 0), NULL_RTX, VOIDmode,
-			    modifier);
-      emit_insn (gen_rtx_USE (VOIDmode, ));
-      return target;
-#endif
-
-    default:
-      gcc_unreachable ();
-    }
-}
-
 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
 
 int
@@ -4841,7 +5134,7 @@ gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED)
 	  TREE_NO_WARNING (*expr_p) = 1;
 	}
 
-      append_to_statement_list (TREE_OPERAND (expr, 0), pre_p);
+      gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
       return GS_OK;
 
     case UNCONSTRAINED_ARRAY_REF:
@@ -4941,10 +5234,6 @@ gnat_gimplify_stmt (tree *stmt_p)
       *stmt_p = STMT_STMT_STMT (stmt);
       return GS_OK;
 
-    case USE_STMT:
-      *stmt_p = NULL_TREE;
-      return GS_ALL_DONE;
-
     case LOOP_STMT:
       {
 	tree gnu_start_label = create_artificial_label ();
@@ -5105,8 +5394,11 @@ process_freeze_entity (Node_Id gnat_node)
     = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
 
   /* If this entity has an Address representation clause, GNU_OLD is the
-     address, so discard it here.  */
-  if (Present (Address_Clause (gnat_entity)))
+     address, so discard it here.  The exception is if this is a subprogram.
+     In that case, GNU_OLD is a TREE_LIST that contains both an address and
+     the ADDR_EXPR needed to take the address of the subprogram.  */
+  if (Present (Address_Clause (gnat_entity))
+      && TREE_CODE (gnu_old) != TREE_LIST)
     gnu_old = 0;
 
   /* Don't do anything for class-wide types they are always
@@ -5119,13 +5411,13 @@ process_freeze_entity (Node_Id gnat_node)
   /* Don't do anything for subprograms that may have been elaborated before
      their freeze nodes.  This can happen, for example because of an inner call
      in an instance body, or a previous compilation of a spec for inlining
-     purposes.  */
-  if  ((gnu_old
-        && TREE_CODE (gnu_old) == FUNCTION_DECL
+     purposes.  ??? Does this still occur?  */
+  if (gnu_old
+      && ((TREE_CODE (gnu_old) == FUNCTION_DECL
 	   && (Ekind (gnat_entity) == E_Function
 	       || Ekind (gnat_entity) == E_Procedure))
-    || (gnu_old
-        && (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
+	  || (TREE_CODE (gnu_old) != TREE_LIST
+	      && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
 	      && Ekind (gnat_entity) == E_Subprogram_Type)))
     return;
 
@@ -5137,7 +5429,8 @@ process_freeze_entity (Node_Id gnat_node)
      freeze node, e.g. while processing the other.  */
   if (gnu_old
       && !(TREE_CODE (gnu_old) == TYPE_DECL
-	   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
+	   && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
+      && TREE_CODE (gnu_old) != TREE_LIST)
     {
       gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
 		   && Present (Full_View (gnat_entity))
@@ -5151,10 +5444,14 @@ process_freeze_entity (Node_Id gnat_node)
   /* Reset the saved tree, if any, and elaborate the object or type for real.
      If there is a full declaration, elaborate it and copy the type to
      GNAT_ENTITY.  Likewise if this is the record subtype corresponding to
-     a class wide type or subtype.  */
-  if (gnu_old)
+     a class wide type or subtype.  First handle the subprogram case: there,
+     we have to set the GNU tree to be the address clause, if any.  */
+  else if (gnu_old)
     {
       save_gnu_tree (gnat_entity, NULL_TREE, false);
+      if (TREE_CODE (gnu_old) == TREE_LIST && TREE_VALUE (gnu_old))
+	save_gnu_tree (gnat_entity, TREE_VALUE (gnu_old), true);
+
       if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
   	  && Present (Full_View (gnat_entity))
   	  && present_gnu_tree (Full_View (gnat_entity)))
@@ -5191,6 +5488,15 @@ process_freeze_entity (Node_Id gnat_node)
   else
     gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
 
+  /* If this was a subprogram being frozen, we have to update the ADDR_EXPR
+     we previously made.  Update the operand, then set up to update the
+     pointers.  */
+  if (gnu_old && TREE_CODE (gnu_old) == TREE_LIST)
+    {
+      TREE_OPERAND (TREE_PURPOSE (gnu_old), 0) = gnu_new;
+      gnu_old = TREE_TYPE (TREE_PURPOSE (gnu_old));
+    }
+
   /* If we've made any pointers to the old version of this type, we
      have to update them.  */
   if (gnu_old)
@@ -5458,7 +5764,7 @@ emit_check (tree gnu_cond, tree gnu_expr, int reason)
   tree gnu_call;
   tree gnu_result;
 
-  gnu_call = build_call_raise (reason, Empty);
+  gnu_call = build_call_raise (reason, Empty, N_Raise_Constraint_Error);
 
   /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
      in front of the comparison in case it ends up being a SAVE_EXPR.  Put the
@@ -6035,18 +6341,13 @@ protect_multiple_eval (tree exp)
 						 exp)));
 }
 
-/* This is equivalent to stabilize_reference in GCC's tree.c, but we know how
-   to handle our new nodes and we take extra arguments:
-
-   FORCE says whether to force evaluation of everything,
-
-   SUCCESS we set to true unless we walk through something we don't know how
-   to stabilize, or through something which is not an lvalue and LVALUES_ONLY
-   is true, in which cases we set to false.  */
+/* This is equivalent to stabilize_reference in tree.c, but we know how to
+   handle our own nodes and we take extra arguments.  FORCE says whether to
+   force evaluation of everything.  We set SUCCESS to true unless we walk
+   through something we don't know how to stabilize.  */
 
 tree
-maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
-			   bool *success)
+maybe_stabilize_reference (tree ref, bool force, bool *success)
 {
   tree type = TREE_TYPE (ref);
   enum tree_code code = TREE_CODE (ref);
@@ -6064,14 +6365,6 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
       return ref;
 
     case ADDR_EXPR:
-      /*  A standalone ADDR_EXPR is never an lvalue, and this one can't
-	  be nested inside an outer INDIRECT_REF, since INDIRECT_REF goes
-	  straight to gnat_stabilize_reference_1.  */
-      if (lvalues_only)
-	goto failure;
-
-      /* ... Fallthru ... */
-
     case NOP_EXPR:
     case CONVERT_EXPR:
     case FLOAT_EXPR:
@@ -6080,7 +6373,7 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
       result
 	= build1 (code, type,
 		  maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
-					     lvalues_only, success));
+					     success));
       break;
 
     case INDIRECT_REF:
@@ -6093,14 +6386,14 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
     case COMPONENT_REF:
      result = build3 (COMPONENT_REF, type,
 		      maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
-						 lvalues_only, success),
+						 success),
 		      TREE_OPERAND (ref, 1), NULL_TREE);
       break;
 
     case BIT_FIELD_REF:
       result = build3 (BIT_FIELD_REF, type,
 		       maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
-						  lvalues_only, success),
+						  success),
 		       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
 						   force),
 		       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
@@ -6111,7 +6404,7 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
     case ARRAY_RANGE_REF:
       result = build4 (code, type,
 		       maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
-						  lvalues_only, success),
+						  success),
 		       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
 						   force),
 		       NULL_TREE, NULL_TREE);
@@ -6122,9 +6415,6 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
       break;
 
     case CALL_EXPR:
-      if (lvalues_only)
-	goto failure;
-
       /* This generates better code than the scheme in protect_multiple_eval
 	 because large objects will be returned via invisible reference in
 	 most ABIs so the temporary will directly be filled by the callee.  */
@@ -6139,7 +6429,6 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
       /* If arg isn't a kind of lvalue we recognize, make no change.
 	 Caller should recognize the error for an invalid lvalue.  */
     default:
-    failure:
       *success = false;
       return ref;
     }
@@ -6165,11 +6454,11 @@ maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
    lvalue restrictions and without need to examine the success
    indication.  */
 
-tree
+static tree
 gnat_stabilize_reference (tree ref, bool force)
 {
-  bool stabilized;
-  return maybe_stabilize_reference (ref, force, false, &stabilized);
+  bool dummy;
+  return maybe_stabilize_reference (ref, force, &dummy);
 }
 
 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
@@ -6443,3 +6732,18 @@ init_code_table (void)
 }
 
 #include "gt-ada-trans.h"
+/* Return a label to branch to for the exception type in KIND or NULL_TREE
+   if none.  */
+
+tree
+get_exception_label (char kind)
+{
+  if (kind == N_Raise_Constraint_Error)
+    return TREE_VALUE (gnu_constraint_error_label_stack);
+  else if (kind == N_Raise_Storage_Error)
+    return TREE_VALUE (gnu_storage_error_label_stack);
+  else if (kind == N_Raise_Program_Error)
+    return TREE_VALUE (gnu_program_error_label_stack);
+  else
+    return NULL_TREE;
+}

gcc/ada/utils.c

@@ -148,27 +148,22 @@ static GTY(()) struct gnat_binding_level *current_binding_level;
 static GTY((deletable)) struct gnat_binding_level *free_binding_level;
 
 /* An array of global declarations.  */
-static GTY(()) VEC (tree,gc) *global_decls;
+static GTY(()) VEC(tree,gc) *global_decls;
 
 /* An array of builtin declarations.  */
-static GTY(()) VEC (tree,gc) *builtin_decls;
+static GTY(()) VEC(tree,gc) *builtin_decls;
 
 /* An array of global renaming pointers.  */
-static GTY(()) VEC (tree,gc) *global_renaming_pointers;
+static GTY(()) VEC(tree,gc) *global_renaming_pointers;
 
 /* Arrays of functions called automatically at the beginning and
    end of execution, on targets without .ctors/.dtors sections.  */
-static GTY(()) VEC (tree,gc) *static_ctors;
-static GTY(()) VEC (tree,gc) *static_dtors;
+static GTY(()) VEC(tree,gc) *static_ctors;
+static GTY(()) VEC(tree,gc) *static_dtors;
 
 /* A chain of unused BLOCK nodes. */
 static GTY((deletable)) tree free_block_chain;
 
-struct language_function GTY(())
-{
-  int unused;
-};
-
 static void gnat_install_builtins (void);
 static tree merge_sizes (tree, tree, tree, bool, bool);
 static tree compute_related_constant (tree, tree);
@@ -246,44 +241,34 @@ init_dummy_type (void)
 tree
 make_dummy_type (Entity_Id gnat_type)
 {
-  Entity_Id gnat_underlying;
+  Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type);
   tree gnu_type;
-  enum tree_code code;
-
-  /* Find a full type for GNAT_TYPE, taking into account any class wide
-     types.  */
-  if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
-    gnat_type = Equivalent_Type (gnat_type);
-  else if (Ekind (gnat_type) == E_Class_Wide_Type)
-    gnat_type = Root_Type (gnat_type);
-
-  /* Find a full view for GNAT_TYPE, looking through any incomplete or
-     private types.  */
-  if (IN (Ekind (gnat_type), Incomplete_Kind)
-      && From_With_Type (gnat_type))
-    gnat_underlying = Non_Limited_View (gnat_type);
-  else if (IN (Ekind (gnat_type), Incomplete_Or_Private_Kind)
-	   && Present (Full_View (gnat_type)))
-    gnat_underlying = Full_View (gnat_type);
-  else
+
+  /* If there is an equivalent type, get its underlying type.  */
+  if (Present (gnat_underlying))
+    gnat_underlying = Underlying_Type (gnat_underlying);
+
+  /* If there was no equivalent type (can only happen when just annotating
+     types) or underlying type, go back to the original type.  */
+  if (No (gnat_underlying))
     gnat_underlying = gnat_type;
 
   /* If it there already a dummy type, use that one.  Else make one.  */
   if (PRESENT_DUMMY_NODE (gnat_underlying))
     return GET_DUMMY_NODE (gnat_underlying);
 
-  /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
-     it an ENUMERAL_TYPE.  */
-  if (Is_Record_Type (gnat_underlying))
-    code = tree_code_for_record_type (gnat_underlying);
-  else
-    code = ENUMERAL_TYPE;
-
-  gnu_type = make_node (code);
+  /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
+     an ENUMERAL_TYPE.  */
+  gnu_type = make_node (Is_Record_Type (gnat_underlying)
+			? tree_code_for_record_type (gnat_underlying)
+			: ENUMERAL_TYPE);
   TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
   TYPE_DUMMY_P (gnu_type) = 1;
   if (AGGREGATE_TYPE_P (gnu_type))
+    {
       TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
+      TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type);
+    }
 
   SET_DUMMY_NODE (gnat_underlying, gnu_type);
 
@@ -469,22 +454,29 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
      set, was set to an IDENTIFIER_NODE, indicating an internal name,
      or if the previous type name was not derived from a source name.
      We'd rather have the type named with a real name and all the pointer
-     types to the same object have the same POINTER_TYPE node.  Code in this
-     function in c-decl.c makes a copy of the type node here, but that may
-     cause us trouble with incomplete types, so let's not try it (at least
-     for now).  */
-
-  if (TREE_CODE (decl) == TYPE_DECL
-      && DECL_NAME (decl)
-      && (!TYPE_NAME (TREE_TYPE (decl))
-	  || TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == IDENTIFIER_NODE
-	  || (TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == TYPE_DECL
-	      && DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl)))
-	      && !DECL_ARTIFICIAL (decl))))
-    TYPE_NAME (TREE_TYPE (decl)) = decl;
+     types to the same object have the same POINTER_TYPE node.  Code in the
+     equivalent function of c-decl.c makes a copy of the type node here, but
+     that may cause us trouble with incomplete types.  We make an exception
+     for fat pointer types because the compiler automatically builds them
+     for unconstrained array types and the debugger uses them to represent
+     both these and pointers to these.  */
+  if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl))
+    {
+      tree t = TREE_TYPE (decl);
 
-  /*  if (TREE_CODE (decl) != CONST_DECL)
-      rest_of_decl_compilation (decl, global_bindings_p (), 0); */
+      if (!TYPE_NAME (t) || TREE_CODE (TYPE_NAME (t)) == IDENTIFIER_NODE)
+	TYPE_NAME (t) = decl;
+      else if (TYPE_FAT_POINTER_P (t))
+	{
+	  tree tt = build_variant_type_copy (t);
+	  TYPE_NAME (tt) = decl;
+	  TREE_USED (tt) = TREE_USED (t);
+	  TREE_TYPE (decl) = tt;
+	  DECL_ORIGINAL_TYPE (decl) = t;
+	}
+      else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl))
+	TYPE_NAME (t) = decl;
+    }
 }
 
 /* Do little here.  Set up the standard declarations later after the
@@ -762,15 +754,19 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
   main_identifier_node = get_identifier ("main");
 }
 
-/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL nodes
-   (FIELDLIST), finish constructing the record or union type.  If HAS_REP is
-   true, this record has a rep clause; don't call layout_type but merely set
-   the size and alignment ourselves.  If DEFER_DEBUG is true, do not call
-   the debugging routines on this type; it will be done later. */
+/* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST,
+   finish constructing the record or union type.  If REP_LEVEL is zero, this
+   record has no representation clause and so will be entirely laid out here.
+   If REP_LEVEL is one, this record has a representation clause and has been
+   laid out already; only set the sizes and alignment.  If REP_LEVEL is two,
+   this record is derived from a parent record and thus inherits its layout;
+   only make a pass on the fields to finalize them.  If DO_NOT_FINALIZE is
+   true, the record type is expected to be modified afterwards so it will
+   not be sent to the back-end for finalization.  */
 
 void
-finish_record_type (tree record_type, tree fieldlist, bool has_rep,
-                    bool defer_debug)
+finish_record_type (tree record_type, tree fieldlist, int rep_level,
+		    bool do_not_finalize)
 {
   enum tree_code code = TREE_CODE (record_type);
   tree ada_size = bitsize_zero_node;
@@ -790,8 +786,7 @@ finish_record_type (tree record_type, tree fieldlist, bool has_rep,
 
   /* Globally initialize the record first.  If this is a rep'ed record,
      that just means some initializations; otherwise, layout the record.  */
-
-  if (has_rep)
+  if (rep_level > 0)
     {
       TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
       TYPE_MODE (record_type) = BLKmode;
@@ -864,7 +859,7 @@ finish_record_type (tree record_type, tree fieldlist, bool has_rep,
       DECL_NONADDRESSABLE_P (field)
 	|= DECL_BIT_FIELD (field) && DECL_MODE (field) != BLKmode;
 
-      if (has_rep && !DECL_BIT_FIELD (field))
+      if ((rep_level > 0) && !DECL_BIT_FIELD (field))
 	TYPE_ALIGN (record_type)
 	  = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
 
@@ -894,9 +889,10 @@ finish_record_type (tree record_type, tree fieldlist, bool has_rep,
 	     the case of empty variants.  */
 	  ada_size
 	    = merge_sizes (ada_size, pos, this_ada_size,
-			   TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
-	  size = merge_sizes (size, pos, this_size,
-			      TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
+			   TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
+	  size
+	    = merge_sizes (size, pos, this_size,
+			   TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
 	  break;
 
 	default:
@@ -907,8 +903,10 @@ finish_record_type (tree record_type, tree fieldlist, bool has_rep,
   if (code == QUAL_UNION_TYPE)
     nreverse (fieldlist);
 
-  /* If this is a padding record, we never want to make the size smaller than
-     what was specified in it, if any.  */
+  if (rep_level < 2)
+    {
+      /* If this is a padding record, we never want to make the size smaller
+	 than what was specified in it, if any.  */
       if (TREE_CODE (record_type) == RECORD_TYPE
 	  && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
 	size = TYPE_SIZE (record_type);
@@ -918,30 +916,34 @@ finish_record_type (tree record_type, tree fieldlist, bool has_rep,
 	  && !TYPE_CONTAINS_TEMPLATE_P (record_type))
 	SET_TYPE_ADA_SIZE (record_type, ada_size);
 
-  if (has_rep)
+      if (rep_level > 0)
 	{
-      tree size_unit
-	= (had_size_unit ? TYPE_SIZE_UNIT (record_type)
-	   : convert (sizetype, size_binop (CEIL_DIV_EXPR, size,
-					    bitsize_unit_node)));
+	  tree size_unit = had_size_unit
+			   ? TYPE_SIZE_UNIT (record_type)
+			   : convert (sizetype,
+				      size_binop (CEIL_DIV_EXPR, size,
+						  bitsize_unit_node));
+	  unsigned int align = TYPE_ALIGN (record_type);
 
-      TYPE_SIZE (record_type)
-	= variable_size (round_up (size, TYPE_ALIGN (record_type)));
+	  TYPE_SIZE (record_type) = variable_size (round_up (size, align));
 	  TYPE_SIZE_UNIT (record_type)
-	= variable_size (round_up (size_unit,
-				   TYPE_ALIGN (record_type) / BITS_PER_UNIT));
+	    = variable_size (round_up (size_unit, align / BITS_PER_UNIT));
 
 	  compute_record_mode (record_type);
 	}
+    }
 
-  if (!defer_debug)
-    write_record_type_debug_info (record_type);
+  if (!do_not_finalize)
+    rest_of_record_type_compilation (record_type);
 }
 
-/* Output the debug information associated to a record type.  */
+/* Wrap up compilation of RECORD_TYPE, i.e. most notably output all
+   the debug information associated with it.  It need not be invoked
+   directly in most cases since finish_record_type takes care of doing
+   so, unless explicitly requested not to through DO_NOT_FINALIZE.  */
 
 void
-write_record_type_debug_info (tree record_type)
+rest_of_record_type_compilation (tree record_type)
 {
   tree fieldlist = TYPE_FIELDS (record_type);
   tree field;
@@ -1027,12 +1029,10 @@ write_record_type_debug_info (tree record_type)
 	    pos = compute_related_constant (curpos, last_pos);
 
 	  if (!pos && TREE_CODE (curpos) == MULT_EXPR
-	      && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST)
+	      && host_integerp (TREE_OPERAND (curpos, 1), 1))
 	    {
-	      /* An offset which is a bit-and operation with a negative
-		 power of 2 means an alignment corresponding to this power
-		 of 2.  */
 	      tree offset = TREE_OPERAND (curpos, 0);
+	      align = tree_low_cst (TREE_OPERAND (curpos, 1), 1);
 
 	      /* Strip off any conversions.  */
 	      while (TREE_CODE (offset) == NON_LVALUE_EXPR
@@ -1040,18 +1040,17 @@ write_record_type_debug_info (tree record_type)
 		     || TREE_CODE (offset) == CONVERT_EXPR)
 		offset = TREE_OPERAND (offset, 0);
 
-	      if (TREE_CODE (offset) == BIT_AND_EXPR)
+	      /* An offset which is a bitwise AND with a negative power of 2
+		 means an alignment corresponding to this power of 2.  */
+	      if (TREE_CODE (offset) == BIT_AND_EXPR
+		  && host_integerp (TREE_OPERAND (offset, 1), 0)
+		  && tree_int_cst_sgn (TREE_OPERAND (offset, 1)) < 0)
 		{
-		  int p = exact_log2
-		    (- TREE_INT_CST_LOW (TREE_OPERAND (offset, 1)));
-
-		  if (p < 0)
-		    p = 1;
-
-		  align = p * TREE_INT_CST_LOW (TREE_OPERAND (curpos, 1));
+		  unsigned int pow
+		    = - tree_low_cst (TREE_OPERAND (offset, 1), 0);
+		  if (exact_log2 (pow) > 0)
+		    align *= pow;
 		}
-	      else
-		align = TREE_INT_CST_LOW (TREE_OPERAND (curpos, 1));
 
 	      pos = compute_related_constant (curpos,
 					      round_up (last_pos, align));
@@ -1085,11 +1084,19 @@ write_record_type_debug_info (tree record_type)
 	  if (!pos)
 	    pos = bitsize_zero_node;
 
-	  /* See if this type is variable-size and make a new type
-	     and indicate the indirection if so.  */
+	  /* See if this type is variable-sized and make a pointer type
+	     and indicate the indirection if so.  Beware that the debug
+	     back-end may adjust the position computed above according
+	     to the alignment of the field type, i.e. the pointer type
+	     in this case, if we don't preventively counter that.  */
 	  if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
 	    {
 	      field_type = build_pointer_type (field_type);
+	      if (align != 0 && TYPE_ALIGN (field_type) > align)
+		{
+		  field_type = copy_node (field_type);
+		  TYPE_ALIGN (field_type) = align;
+		}
 	      var = true;
 	    }
 
@@ -1129,10 +1136,10 @@ write_record_type_debug_info (tree record_type)
       TYPE_FIELDS (new_record_type)
 	= nreverse (TYPE_FIELDS (new_record_type));
 
-      rest_of_type_compilation (new_record_type, true);
+      rest_of_type_decl_compilation (TYPE_STUB_DECL (new_record_type));
     }
 
-  rest_of_type_compilation (record_type, true);
+  rest_of_type_decl_compilation (TYPE_STUB_DECL (record_type));
 }
 
 /* Utility function of above to merge LAST_SIZE, the previous size of a record
@@ -1313,10 +1320,11 @@ copy_type (tree type)
 }
 
 /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
-   TYPE_INDEX_TYPE is INDEX.  */
+   TYPE_INDEX_TYPE is INDEX.  GNAT_NODE is used for the position of
+   the decl.  */
 
 tree
-create_index_type (tree min, tree max, tree index)
+create_index_type (tree min, tree max, tree index, Node_Id gnat_node)
 {
   /* First build a type for the desired range.  */
   tree type = build_index_2_type (min, max);
@@ -1332,7 +1340,7 @@ create_index_type (tree min, tree max, tree index)
     type = copy_type (type);
 
   SET_TYPE_INDEX_TYPE (type, index);
-  create_type_decl (NULL_TREE, type, NULL, true, false, Empty);
+  create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node);
   return type;
 }
 
@@ -1361,15 +1369,13 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list,
      UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
      and ENUMERAL_TYPE or RECORD_TYPE which is handled separately, or
      type for which debugging information was not requested.  */
-  if (code == UNCONSTRAINED_ARRAY_TYPE || ! debug_info_p)
-    DECL_IGNORED_P (type_decl) = 1;
-  if (code == UNCONSTRAINED_ARRAY_TYPE || TYPE_IS_DUMMY_P (type)
-      || !debug_info_p)
+  if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
     DECL_IGNORED_P (type_decl) = 1;
-  else if (code != ENUMERAL_TYPE && code != RECORD_TYPE
+  else if (code != ENUMERAL_TYPE
+	   && (code != RECORD_TYPE || TYPE_IS_FAT_POINTER_P (type))
 	   && !((code == POINTER_TYPE || code == REFERENCE_TYPE)
 		&& TYPE_IS_DUMMY_P (TREE_TYPE (type))))
-    rest_of_decl_compilation (type_decl, global_bindings_p (), 0);
+    rest_of_type_decl_compilation (type_decl);
 
   return type_decl;
 }
@@ -1402,30 +1408,35 @@ create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
 		   struct attrib *attr_list, Node_Id gnat_node)
 {
   bool init_const
-    = (!var_init
-       ? false
-       : (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
+    = (var_init != 0
+       && TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
        && (global_bindings_p () || static_flag
-	      ? 0 != initializer_constant_valid_p (var_init,
-						   TREE_TYPE (var_init))
-	      : TREE_CONSTANT (var_init))));
+	   ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) != 0
+	   : TREE_CONSTANT (var_init)));
+
+  /* Whether we will make TREE_CONSTANT the DECL we produce here, in which
+     case the initializer may be used in-lieu of the DECL node (as done in
+     Identifier_to_gnu).  This is useful to prevent the need of elaboration
+     code when an identifier for which such a decl is made is in turn used as
+     an initializer.  We used to rely on CONST vs VAR_DECL for this purpose,
+     but extra constraints apply to this choice (see below) and are not
+     relevant to the distinction we wish to make. */
+  bool constant_p = const_flag && init_const;
+
+  /* The actual DECL node.  CONST_DECL was initially intended for enumerals
+     and may be used for scalars in general but not for aggregates.  */
   tree var_decl
-    = build_decl ((const_flag && const_decl_allowed_flag && init_const
-		   /* Only make a CONST_DECL for sufficiently-small objects.
-		      We consider complex double "sufficiently-small"  */
-		   && TYPE_SIZE (type) != 0
-		   && host_integerp (TYPE_SIZE_UNIT (type), 1)
-		   && 0 >= compare_tree_int (TYPE_SIZE_UNIT (type),
-					     GET_MODE_SIZE (DCmode)))
-		  ? CONST_DECL : VAR_DECL, var_name, type);
-
-  /* If this is external, throw away any initializations unless this is a
-     CONST_DECL (meaning we have a constant); they will be done elsewhere.
-     If we are defining a global here, leave a constant initialization and
-     save any variable elaborations for the elaboration routine.  If we are
-     just annotating types, throw away the initialization if it isn't a
-     constant.  */
-  if ((extern_flag && TREE_CODE (var_decl) != CONST_DECL)
+    = build_decl ((constant_p && const_decl_allowed_flag
+		   && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL,
+		  var_name, type);
+
+  /* If this is external, throw away any initializations (they will be done
+     elsewhere) unless this is a a constant for which we would like to remain
+     able to get the initializer.  If we are defining a global here, leave a
+     constant initialization and save any variable elaborations for the
+     elaboration routine.  If we are just annotating types, throw away the
+     initialization if it isn't a constant.  */
+  if ((extern_flag && !constant_p)
       || (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
     var_init = NULL_TREE;
 
@@ -1447,7 +1458,7 @@ create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
   TREE_READONLY (var_decl) = const_flag;
   DECL_EXTERNAL (var_decl) = extern_flag;
   TREE_PUBLIC   (var_decl) = public_flag || extern_flag;
-  TREE_CONSTANT (var_decl) = TREE_CODE (var_decl) == CONST_DECL;
+  TREE_CONSTANT (var_decl) = constant_p;
   TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
     = TYPE_VOLATILE (type);
 
@@ -1570,7 +1581,7 @@ create_field_decl (tree field_name, tree field_type, tree record_type,
       && size
       && TREE_CODE (size) == INTEGER_CST
       && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
-      && (!operand_equal_p (TYPE_SIZE (field_type), size, 0)
+      && (!tree_int_cst_equal (size, TYPE_SIZE (field_type))
 	  || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type)))
 	  || packed
 	  || (TYPE_ALIGN (record_type) != 0
@@ -2510,8 +2521,8 @@ build_template (tree template_type, tree array_type, tree expr)
       else
 	gcc_unreachable ();
 
-      min = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MIN_VALUE (bounds));
-      max = convert (TREE_TYPE (field), TYPE_MAX_VALUE (bounds));
+      min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds));
+      max = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MAX_VALUE (bounds));
 
       /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
 	 substitute it from OBJECT.  */
@@ -2536,6 +2547,7 @@ tree
 build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 {
   tree record_type = make_node (RECORD_TYPE);
+  tree pointer32_type;
   tree field_list = 0;
   int class;
   int dtype = 0;
@@ -2655,8 +2667,11 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
     case By_Descriptor_SB:
       class = 15;
       break;
+    case By_Descriptor:
+    case By_Descriptor_S:
     default:
       class = 1;
+      break;
     }
 
   /* Make the type for a descriptor for VMS.  The first four fields
@@ -2677,13 +2692,16 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 					       gnat_type_for_size (8, 1),
 					       record_type, size_int (class)));
 
+  /* Of course this will crash at run-time if the address space is not
+     within the low 32 bits, but there is nothing else we can do.  */
+  pointer32_type = build_pointer_type_for_mode (type, SImode, false);
+
   field_list
     = chainon (field_list,
 	       make_descriptor_field
-	       ("POINTER",
-		build_pointer_type_for_mode (type, SImode, false), record_type,
-		build1 (ADDR_EXPR,
-			build_pointer_type_for_mode (type, SImode, false),
+	       ("POINTER", pointer32_type, record_type,
+		build_unary_op (ADDR_EXPR,
+				pointer32_type,
 				build0 (PLACEHOLDER_EXPR, type))));
 
   switch (mech)
@@ -2702,7 +2720,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
       field_list
 	= chainon (field_list,
 		   make_descriptor_field
-		   ("SB_L2", gnat_type_for_size (32, 1), record_type,
+		   ("SB_U1", gnat_type_for_size (32, 1), record_type,
 		    TREE_CODE (type) == ARRAY_TYPE
 		    ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
       break;
@@ -2764,7 +2782,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 			    tem)));
 
       /* Next come the addressing coefficients.  */
-      tem = size_int (1);
+      tem = size_one_node;
       for (i = 0; i < ndim; i++)
 	{
 	  char fname[3];
@@ -2813,7 +2831,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
       post_error ("unsupported descriptor type for &", gnat_entity);
     }
 
-  finish_record_type (record_type, field_list, false, true);
+  finish_record_type (record_type, field_list, 0, true);
   create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type,
 		    NULL, true, false, gnat_entity);
 
@@ -2833,6 +2851,183 @@ make_descriptor_field (const char *name, tree type,
   return field;
 }
 
+/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
+   pointer or fat pointer type.  GNAT_SUBPROG is the subprogram to which
+   the VMS descriptor is passed.  */
+
+static tree
+convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
+{
+  tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
+  tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
+  /* The CLASS field is the 3rd field in the descriptor.  */
+  tree class = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type)));
+  /* The POINTER field is the 4th field in the descriptor.  */
+  tree pointer = TREE_CHAIN (class);
+
+  /* Retrieve the value of the POINTER field.  */
+  gnu_expr
+    = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
+
+  if (POINTER_TYPE_P (gnu_type))
+    return convert (gnu_type, gnu_expr);
+
+  else if (TYPE_FAT_POINTER_P (gnu_type))
+    {
+      tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
+      tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
+      tree template_type = TREE_TYPE (p_bounds_type);
+      tree min_field = TYPE_FIELDS (template_type);
+      tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type));
+      tree template, template_addr, aflags, dimct, t, u;
+      /* See the head comment of build_vms_descriptor.  */
+      int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class));
+
+      /* Convert POINTER to the type of the P_ARRAY field.  */
+      gnu_expr = convert (p_array_type, gnu_expr);
+
+      switch (iclass)
+	{
+	case 1:  /* Class S  */
+	case 15: /* Class SB */
+	  /* Build {1, LENGTH} template; LENGTH is the 1st field.  */
+	  t = TYPE_FIELDS (desc_type);
+	  t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  t = tree_cons (min_field,
+			 convert (TREE_TYPE (min_field), integer_one_node),
+			 tree_cons (max_field,
+				    convert (TREE_TYPE (max_field), t),
+				    NULL_TREE));
+	  template = gnat_build_constructor (template_type, t);
+	  template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
+
+	  /* For class S, we are done.  */
+	  if (iclass == 1)
+	    break;
+
+	  /* Test that we really have a SB descriptor, like DEC Ada.  */
+	  t = build3 (COMPONENT_REF, TREE_TYPE (class), desc, class, NULL);
+	  u = convert (TREE_TYPE (class), DECL_INITIAL (class));
+	  u = build_binary_op (EQ_EXPR, integer_type_node, t, u);
+	  /* If so, there is already a template in the descriptor and
+	     it is located right after the POINTER field.  */
+	  t = TREE_CHAIN (pointer);
+	  template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  /* Otherwise use the {1, LENGTH} template we build above.  */
+	  template_addr = build3 (COND_EXPR, p_bounds_type, u,
+				  build_unary_op (ADDR_EXPR, p_bounds_type,
+				 		 template),
+				  template_addr);
+	  break;
+
+	case 4:  /* Class A */
+	  /* The AFLAGS field is the 7th field in the descriptor.  */
+	  t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer)));
+	  aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  /* The DIMCT field is the 8th field in the descriptor.  */
+	  t = TREE_CHAIN (t);
+	  dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  /* Raise CONSTRAINT_ERROR if either more than 1 dimension
+	     or FL_COEFF or FL_BOUNDS not set.  */
+	  u = build_int_cst (TREE_TYPE (aflags), 192);
+	  u = build_binary_op (TRUTH_OR_EXPR, integer_type_node,
+			       build_binary_op (NE_EXPR, integer_type_node,
+						dimct,
+						convert (TREE_TYPE (dimct),
+							 size_one_node)),
+			       build_binary_op (NE_EXPR, integer_type_node,
+						build2 (BIT_AND_EXPR,
+							TREE_TYPE (aflags),
+							aflags, u),
+						u));
+	  add_stmt (build3 (COND_EXPR, void_type_node, u,
+			    build_call_raise (CE_Length_Check_Failed, Empty,
+					      N_Raise_Constraint_Error),
+			    NULL_TREE));
+	  /* There is already a template in the descriptor and it is
+	     located at the start of block 3 (12th field).  */
+	  t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t))));
+	  template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template);
+	  break;
+
+	case 10: /* Class NCA */
+	default:
+	  post_error ("unsupported descriptor type for &", gnat_subprog);
+	  template_addr = integer_zero_node;
+	  break;
+	}
+
+      /* Build the fat pointer in the form of a constructor.  */
+      t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr,
+		     tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)),
+				template_addr, NULL_TREE));
+      return gnat_build_constructor (gnu_type, t);
+    }
+
+  else
+    gcc_unreachable ();
+}
+
+/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
+   and the GNAT node GNAT_SUBPROG.  */
+
+void
+build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
+{
+  tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
+  tree gnu_stub_param, gnu_param_list, gnu_arg_types, gnu_param;
+  tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
+  tree gnu_body;
+
+  gnu_subprog_type = TREE_TYPE (gnu_subprog);
+  gnu_param_list = NULL_TREE;
+
+  begin_subprog_body (gnu_stub_decl);
+  gnat_pushlevel ();
+
+  start_stmt_group ();
+
+  /* Loop over the parameters of the stub and translate any of them
+     passed by descriptor into a by reference one.  */
+  for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
+       gnu_arg_types = TYPE_ARG_TYPES (gnu_subprog_type);
+       gnu_stub_param;
+       gnu_stub_param = TREE_CHAIN (gnu_stub_param),
+       gnu_arg_types = TREE_CHAIN (gnu_arg_types))
+    {
+      if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
+	gnu_param = convert_vms_descriptor (TREE_VALUE (gnu_arg_types),
+					    gnu_stub_param, gnat_subprog);
+      else
+	gnu_param = gnu_stub_param;
+
+      gnu_param_list = tree_cons (NULL_TREE, gnu_param, gnu_param_list);
+    }
+
+  gnu_body = end_stmt_group ();
+
+  /* Invoke the internal subprogram.  */
+  gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
+			     gnu_subprog);
+  gnu_subprog_call = build3 (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
+			     gnu_subprog_addr, nreverse (gnu_param_list),
+			     NULL_TREE);
+
+  /* Propagate the return value, if any.  */
+  if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
+    append_to_statement_list (gnu_subprog_call, &gnu_body);
+  else
+    append_to_statement_list (build_return_expr (DECL_RESULT (gnu_stub_decl),
+						 gnu_subprog_call),
+			      &gnu_body);
+
+  gnat_poplevel ();
+
+  allocate_struct_function (gnu_stub_decl);
+  end_subprog_body (gnu_body);
+}
+
 /* Build a type to be used to represent an aliased object whose nominal
    type is an unconstrained array.  This consists of a RECORD_TYPE containing
    a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
@@ -2854,7 +3049,7 @@ build_unc_object_type (tree template_type, tree object_type, tree name)
   finish_record_type (type,
 		      chainon (chainon (NULL_TREE, template_field),
 			       array_field),
-		      false, false);
+		      0, false);
 
   return type;
 }
@@ -2876,6 +3071,27 @@ build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
   return build_unc_object_type (template_type, object_type, name);
 }
 
+/* Shift the component offsets within an unconstrained object TYPE to make it
+   suitable for use as a designated type for thin pointers.  */
+
+void
+shift_unc_components_for_thin_pointers (tree type)
+{
+  /* Thin pointer values designate the ARRAY data of an unconstrained object,
+     allocated past the BOUNDS template.  The designated type is adjusted to
+     have ARRAY at position zero and the template at a negative offset, so
+     that COMPONENT_REFs on (*thin_ptr) designate the proper location.  */
+
+  tree bounds_field = TYPE_FIELDS (type);
+  tree array_field  = TREE_CHAIN (TYPE_FIELDS (type));
+
+  DECL_FIELD_OFFSET (bounds_field)
+    = size_binop (MINUS_EXPR, size_zero_node, byte_position (array_field));
+
+  DECL_FIELD_OFFSET (array_field) = size_zero_node;
+  DECL_FIELD_BIT_OFFSET (array_field) = bitsize_zero_node;
+}
+
 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.  In
    the normal case this is just two adjustments, but we have more to do
    if NEW is an UNCONSTRAINED_ARRAY_TYPE.  */
@@ -3002,23 +3218,26 @@ update_pointer_to (tree old_type, tree new_type)
 
       update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec);
 
-      TREE_TYPE (TYPE_FIELDS (new_obj_rec)) = TREE_TYPE (ptr_temp_type);
+      TREE_TYPE (TYPE_FIELDS (new_obj_rec))
+	= TREE_TYPE (TREE_TYPE (TREE_CHAIN (new_fields)));
+
       TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
 	= TREE_TYPE (TREE_TYPE (new_fields));
-      DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
-	= TYPE_SIZE (TREE_TYPE (TREE_TYPE (new_fields)));
-      DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
-	= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (new_fields)));
 
-      TYPE_SIZE (new_obj_rec)
-	= size_binop (PLUS_EXPR,
-		      DECL_SIZE (TYPE_FIELDS (new_obj_rec)),
-		      DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
-      TYPE_SIZE_UNIT (new_obj_rec)
-	= size_binop (PLUS_EXPR,
-		      DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec)),
-		      DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
-      rest_of_type_compilation (ptr, global_bindings_p ());
+      /* The size recomputation needs to account for alignment constraints, so
+	 we let layout_type work it out.  This will reset the field offsets to
+	 what they would be in a regular record, so we shift them back to what
+	 we want them to be for a thin pointer designated type afterwards.  */
+
+      DECL_SIZE (TYPE_FIELDS (new_obj_rec)) = 0;
+      DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))) = 0;
+      TYPE_SIZE (new_obj_rec) = 0;
+      layout_type (new_obj_rec);
+
+      shift_unc_components_for_thin_pointers (new_obj_rec);
+
+      /* We are done, at last.  */
+      rest_of_record_type_compilation (ptr);
     }
 }
 
@@ -3617,7 +3836,8 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
 	 into a base type, we need to ensure that VRP doesn't propagate range
 	 information since this conversion may be done precisely to validate
 	 that the object is within the range it is supposed to have.  */
-      else if (TREE_CODE (type) == INTEGER_TYPE && !TREE_TYPE (type)
+      else if (TREE_CODE (expr) != INTEGER_CST
+	       && TREE_CODE (type) == INTEGER_TYPE && !TREE_TYPE (type)
 	       && ((TREE_CODE (etype) == INTEGER_TYPE && TREE_TYPE (etype))
 		   || TREE_CODE (etype) == ENUMERAL_TYPE
 		   || TREE_CODE (etype) == BOOLEAN_TYPE))