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)
* *
* 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- *
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
#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))
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
* *
* 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- *
/* 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
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);
/* 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);
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);
/* 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.
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;
/* 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,
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.
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
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. */
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. */
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
* *
* 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- *
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++;
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. */
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
init_eh ();
#ifdef DWARF2_UNWIND_INFO
- if (dwarf2out_do_frame ())
+ if (!dwarf2out_frame_initialized && dwarf2out_do_frame ())
dwarf2out_frame_init ();
#endif
}
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))
{
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;
}
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
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];
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 *);
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);
\f
/* This is the main program of the back-end. It sets up all the table
structures and then generates code. */
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);
/* 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);
+ {
+ 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
set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
}
\f
+/* 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. */
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
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))
gnat_temp_type = Actual_Subtype (gnat_temp);
else
gnat_temp_type = Etype (gnat_node);
+ }
- gnu_result_type = get_unpadded_type (gnat_temp_type);
+ /* 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;
}
- gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
+ 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
ensure optimization does not remove stores that appear redundant but are
/* 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
&& (! 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;
}
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)
+ /* 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))
{
- 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)))))
+ 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);
}
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);
}
{
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));
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)
- gnu_result
- = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
+ {
+ 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)
- gnu_result
- = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
- else
- /* 'Length or 'Range_Length. */
{
- tree gnu_compute_type
+ if (pa && pa->last)
+ {
+ gnu_result = pa->last;
+ break;
+ }
+
+ gnu_result
+ = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
+ }
+
+ else /* attribute == Attr_Range_Length || attribute == Attr_Length */
+ {
+ 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));
+ get_base_type (gnu_result_type));
gnu_result
= build_binary_op
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;
}
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 ... */
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
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. */
|| 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
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);
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.
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 ();
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. */
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 ();
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);
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;
}
\f
/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
{
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)
{
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. */
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 ();
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)));
+ {
+ add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
+ finalize_from_with_types ();
+ }
process_inlined_subprograms (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. */
&& 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
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;
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),
/* 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;
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: */
/*******************************/
/* 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. */
- save_gnu_tree (Entity (Name (gnat_node)),
- gnat_to_gnu (Expression (gnat_node)), true);
+ 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;
case N_Enumeration_Representation_Clause:
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
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
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,
return gnu_result;
}
\f
+/* 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);
+}
+\f
/* Record the current code position in GNAT_NODE. */
static void
\f
/* 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;
add_stmt_with_node (gnu_stmt, gnat_entity);
/* If this is a variable and an initializer is attached to it, it must be
- valid for the context. Similar to init_const in create_var_decl_1. */
+ valid for the context. Similar to init_const in create_var_decl_1. */
if (TREE_CODE (gnu_decl) == VAR_DECL
&& (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
&& (TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (TREE_TYPE (gnu_init))
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, ¤t_stmt_group->cleanups);
}
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;
gnu_stack_free_list = gnu_node;
}
\f
-/* 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 ();
- }
-}
-\f
/* Generate GIMPLE in place for the expression at *EXPR_P. */
int
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:
*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 ();
= 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
/* 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
- && (Ekind (gnat_entity) == E_Function
- || Ekind (gnat_entity) == E_Procedure))
- || (gnu_old
- && (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
- && Ekind (gnat_entity) == E_Subprogram_Type)))
+ purposes. ??? Does this still occur? */
+ if (gnu_old
+ && ((TREE_CODE (gnu_old) == FUNCTION_DECL
+ && (Ekind (gnat_entity) == E_Function
+ || Ekind (gnat_entity) == E_Procedure))
+ || (TREE_CODE (gnu_old) != TREE_LIST
+ && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
+ && Ekind (gnat_entity) == E_Subprogram_Type)))
return;
/* If we have a non-dummy type old tree, we have nothing to do, except
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))
/* 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)))
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)
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
exp)));
}
\f
-/* 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);
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:
result
= build1 (code, type,
maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- lvalues_only, success));
+ success));
break;
case INDIRECT_REF:
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),
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);
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. */
/* 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;
}
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
}
#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;
+}
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);
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_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);
add_decl_expr (decl, gnat_node);
/* Put the declaration on the list. The list of declarations is in reverse
- order. The list will be reversed later. Put global variables in the
+ order. The list will be reversed later. Put global variables in the
globals list and builtin functions in a dedicated list to speed up
further lookups. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into
the list, as they will cause trouble with the debugger and aren't needed
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;
-
- /* if (TREE_CODE (decl) != CONST_DECL)
- rest_of_decl_compilation (decl, global_bindings_p (), 0); */
+ 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 (!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;
+ }
}
\f
/* Do little here. Set up the standard declarations later after the
main_identifier_node = get_identifier ("main");
}
\f
-/* 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;
/* 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;
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));
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:
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 (TREE_CODE (record_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
- size = TYPE_SIZE (record_type);
-
- /* Now set any of the values we've just computed that apply. */
- if (!TYPE_IS_FAT_POINTER_P (record_type)
- && !TYPE_CONTAINS_TEMPLATE_P (record_type))
- SET_TYPE_ADA_SIZE (record_type, ada_size);
-
- if (has_rep)
+ if (rep_level < 2)
{
- tree size_unit
- = (had_size_unit ? TYPE_SIZE_UNIT (record_type)
- : convert (sizetype, size_binop (CEIL_DIV_EXPR, size,
- bitsize_unit_node)));
-
- TYPE_SIZE (record_type)
- = variable_size (round_up (size, TYPE_ALIGN (record_type)));
- TYPE_SIZE_UNIT (record_type)
- = variable_size (round_up (size_unit,
- TYPE_ALIGN (record_type) / BITS_PER_UNIT));
-
- compute_record_mode (record_type);
+ /* 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);
+
+ /* Now set any of the values we've just computed that apply. */
+ if (!TYPE_IS_FAT_POINTER_P (record_type)
+ && !TYPE_CONTAINS_TEMPLATE_P (record_type))
+ SET_TYPE_ADA_SIZE (record_type, ada_size);
+
+ 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));
+ unsigned int align = 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, 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;
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
|| 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));
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;
}
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
}
\f
/* 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);
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;
}
\f
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)
+ 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)
- 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;
}
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))
- && (global_bindings_p () || static_flag
- ? 0 != initializer_constant_valid_p (var_init,
- TREE_TYPE (var_init))
- : TREE_CONSTANT (var_init))));
+ = (var_init != 0
+ && TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
+ && (global_bindings_p () || static_flag
+ ? 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;
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);
&& 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
}
\f
/* Set up the framework for generating code for SUBPROG_DECL, a subprogram
- body. This routine needs to be invoked before processing the declarations
+ body. This routine needs to be invoked before processing the declarations
appearing in the subprogram. */
void
&& TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
bound_list = TYPE_ACTUAL_BOUNDS (array_type);
- /* First make the list for a CONSTRUCTOR for the template. Go down the
+ /* First make the list for a CONSTRUCTOR for the template. Go down the
field list of the template instead of the type chain because this
array might be an Ada array of arrays and we can't tell where the
nested arrays stop being the underlying object. */
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. */
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;
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
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),
- build0 (PLACEHOLDER_EXPR, type))));
+ ("POINTER", pointer32_type, record_type,
+ build_unary_op (ADDR_EXPR,
+ pointer32_type,
+ build0 (PLACEHOLDER_EXPR, type))));
switch (mech)
{
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;
tem)));
/* Next come the addressing coefficients. */
- tem = size_int (1);
+ tem = size_one_node;
for (i = 0; i < ndim; i++)
{
char fname[3];
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);
DECL_INITIAL (field) = initial;
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);
+}
\f
/* 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
finish_record_type (type,
chainon (chainon (NULL_TREE, template_field),
array_field),
- false, false);
+ 0, false);
return type;
}
: TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_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;
+}
\f
/* 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
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);
}
}
\f
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))
projects / platform / upstream / gcc.git / commitdiff