mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 22:11:30 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Gary Dismukes 2007-06-06 12:16:54 +02:00 committed by Arnaud Charlet
parent fce2526fe8
commit 09ef48fe18
8 changed files with 1019 additions and 419 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
gcc/ada/ada-tree.def
View File

@ -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)

12
gcc/ada/ada-tree.h
View File

@ -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))

8
gcc/ada/fe.h
View File

@ -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

113
gcc/ada/gigi.h
View File

@ -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. */

6
gcc/ada/lang.opt
View File

@ -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

36
gcc/ada/misc.c
View File

@ -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;
}

698
gcc/ada/trans.c
View File

File diff suppressed because it is too large Load Diff

562
gcc/ada/utils.c
View File

@ -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);
/* If there is an equivalent type, get its underlying type. */
if (Present (gnat_underlying))
gnat_underlying = Underlying_Type (gnat_underlying);
/* 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 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);
@ -443,7 +428,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
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
@ -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). */
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) == 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); */
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,41 +903,47 @@ 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 (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)));
/* 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);
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));
/* 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);
compute_record_mode (record_type);
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;
@ -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)
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;
}
@ -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))
&& (global_bindings_p () || static_flag
? 0 != initializer_constant_valid_p (var_init,
TREE_TYPE (var_init))
: TREE_CONSTANT (var_init))));
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);
= (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)));
/* 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)
/* 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 ((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
@ -1908,7 +1919,7 @@ create_subprog_decl (tree subprog_name, tree asm_name,
}
/* 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
@ -2483,7 +2494,7 @@ build_template (tree template_type, tree array_type, tree expr)
&& 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. */
@ -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,14 +2692,17 @@ 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),
build0 (PLACEHOLDER_EXPR, type))));
("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);
@ -2832,6 +2850,183 @@ make_descriptor_field (const char *name, tree type,
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);
}
/* 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
@ -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;
}
@ -2875,6 +3070,27 @@ build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_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;
}
/* 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
@ -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))