OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

decl.c: Factor common code to build a storage type for an unconstrained object from a... 

2005-11-14  Thomas Quinot  <quinot@adacore.com>
	    Olivier Hainque  <hainque@adacore.com>
	    Eric Botcazou  <ebotcazou@adacore.com>

	* decl.c:
	Factor common code to build a storage type for an unconstrained object
	from a fat or thin pointer type and a constrained object type.
	(annotate_value): Handle BIT_AND_EXPR.
	(annotate_rep): Don't restrict the back annotation of inherited
	components to the type_annotate_only case.
	(gnat_to_gnu_entity) <E_Array_Type>: Do not invoke create_type_decl if
	we are not defining the type.
	<E_Record_Type>: Likewise.
	(gnat_to_gnu_entity) <object, renaming>: Adjust comments and structure
	to get advantage of the new maybe_stabilize_reference interface, to
	ensure that what we reference is indeed stabilized instead of relying
	on assumptions on what the stabilizer does.
	(gnat_to_gnu_entity) <E_Incomplete_Type>: If the entity is an incomplete
	type imported through a limited_with clause, use its non-limited view.
	(Has_Stdcall_Convention): New macro, to centralize the Windows vs others
	differentiation.
	(gnat_to_gnu_entity): Use Has_Stdcall_Convention instead of a spread mix
	of #if sections + explicit comparisons of convention identifiers.
	(gnat_to_gnu_entity) <E_Variable>: Decrement force_global if necessary
	before early-returning for certain types when code generation is
	disabled.
	(gnat_to_gnu_entity) <object>: Adjust comment attached to the
	nullification of gnu_expr we do for objects with address clause and
	that we are not defining.
	(elaborate_expression_1): Do not create constants when creating
	variables needed by the debug info: the dwarf2 writer considers that
	CONST_DECLs is used only to represent enumeration constants, and emits
	nothing for them.
	(gnat_to_gnu_entity) <object>: When turning a non-definition of an
	object with an address clause into an indirect reference, drop the
	initializing expression.
	Include "expr.h".
	(STACK_CHECK_BUILTIN): Delete.
	(STACK_CHECK_PROBE_INTERVAL): Likewise.
	(STACK_CHECK_MAX_FRAME_SIZE): Likewise.
	(STACK_CHECK_MAX_VAR_SIZE): Likewise.
	(gnat_to_gnu_entity): If gnat_entity is a renaming, do not mark the tree
	corresponding to the renamed object as ignored for debugging purposes.

	* trans.c (tree_transform, case N_Attribute_Reference, case Attr_Size &
	related): For a prefix that is a dereference of a fat or thin pointer,
	if there is an actual subtype provided by the front-end, use that
	subtype to build an actual type with bounds template.
	(tree_transform, case N_Free_Statement): If an Actual_Designated_Subtype
	is provided by the front-end, use that subtype to compute the size of
	the deallocated object.
	(gnat_to_gnu): When adding a statement into an elaboration procedure,
	check for a potential violation of a No_Elaboration_Code restriction.
	(maybe_stabilize_reference): New function, like gnat_stabilize_reference
	with extra arguments to control whether to recurse through non-values
	and to let the caller know if the stabilization has succeeded.
	(gnat_stabilize_reference): Now a simple wrapper around
	maybe_stabilize, for common uses without restriction on lvalues and
	without need to check for the success indication.
	(gnat_to_gnu, call_to_gnu): Adjust calls to gnat_stabilize_reference, to
	pass false instead of 0 as the FORCE argument which is a bool.
	(Identifier_to_gnu): Remove checks ensuring that an renamed object
	attached to a renaming pointer has been properly stabilized, as no such
	object is attached otherwise.
	(call_to_gnu): Invoke create_var_decl to create the temporary when the
	function uses the "target pointer" return mechanism.
	Reinstate conversion of the actual to the type of the formal
	parameter before any other specific treatment based on the passing
	mechanism. This turns out to be necessary in order for PLACEHOLDER
	substitution to work properly when the latter type is unconstrained.

	* gigi.h (build_unc_object_type_from_ptr): New subprogram, factoring a
	common pattern.
	(maybe_stabilize_reference): New function, like gnat_stabilize_reference
	with extra arguments to control whether to recurse through non-values
	and to let the caller know if the stabilization has succeeded.

	* utils2.c (gnat_build_constructor): Only sort the fields for possible
	static output of record constructor if all the components are constant.
	(gnat_build_constructor): For a record type, sort the list of field
	initializers in increasing bit position order.
	Factor common code to build a storage type for an unconstrained object
	from a fat or thin pointer type and a constrained object type.
	(build_unary_op) <ADDR_EXPR>: Always recurse down conversions between
	types variants, and process special cases of VIEW_CONVERT expressions
	as their NOP_EXPR counterpart to ensure we get to the
	CORRESPONDING_VARs associated with CONST_DECls.
	(build_binary_op) <MODIFY_EXPR>: Do not strip VIEW_CONVERT_EXPRs
	on the right-hand side.

	* utils.c (build_unc_object_type_from_ptr): New subprogram, factoring
	a common pattern.
	(convert) <VIEW_CONVERT_EXPR>: Return the inner operand directly if we
	are converting back to its original type.
	(convert) <JM input>: Fallthrough regular conversion code instead of
	extracting the object if converting to a type variant.
	(create_var_decl): When a variable has an initializer requiring code
	generation and we are at the top level, check for a potential violation
	of a No_Elaboration_Code restriction.
	(create_var_decl): call expand_decl for CONST_DECLs, to set MODE, ALIGN
	SIZE and SIZE_UNIT which we need for later back-annotations.
	* utils.c: (convert) <STRING_CST>: Remove obsolete code.
	<VIEW_CONVERT_EXPR>: Do not lift the conversion if the target type
	is an unchecked union.
	(pushdecl): Set DECL_NO_STATIC_CHAIN on imported nested functions.
	(convert) <VIEW_CONVERT_EXPR>: When the types have the same
	main variant, just replace the VIEW_CONVERT_EXPR.
	<UNION_TYPE>: Revert 2005-03-02 change.

	* repinfo.h, repinfo.ads: Add tcode for BIT_AND_EXPR.

	* repinfo.adb (Print_Expr, Rep_Value): Handle Bit_And_Expressions.

From-SVN: r106961
This commit is contained in:
Thomas Quinot 2005-11-15 14:53:22 +01:00 committed by Arnaud Charlet
parent fda5d6d4ff
commit 5e61ef090a
8 changed files with 551 additions and 315 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

275
gcc/ada/decl.c
View File

@ -35,6 +35,7 @@
#include "ggc.h"
#include "obstack.h"
#include "target.h"
#include "expr.h"
#include "ada.h"
#include "types.h"
@ -52,21 +53,14 @@
#include "ada-tree.h"
#include "gigi.h"
/* Provide default values for the macros controlling stack checking.
This is copied from GCC's expr.h. */
/* Convention_Stdcall should be processed in a specific way on Windows targets
only. The macro below is a helper to avoid having to check for a Windows
specific attribute throughout this unit. */
#ifndef STACK_CHECK_BUILTIN
#define STACK_CHECK_BUILTIN 0
#endif
#ifndef STACK_CHECK_PROBE_INTERVAL
#define STACK_CHECK_PROBE_INTERVAL 4096
#endif
#ifndef STACK_CHECK_MAX_FRAME_SIZE
#define STACK_CHECK_MAX_FRAME_SIZE \
(STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD)
#endif
#ifndef STACK_CHECK_MAX_VAR_SIZE
#define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100)
#if TARGET_DLLIMPORT_DECL_ATTRIBUTES
#define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
#else
#define Has_Stdcall_Convention(E) (0)
#endif
/* These two variables are used to defer recursively expanding incomplete
@ -531,6 +525,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| TREE_CODE (gnu_type) == VOID_TYPE)
{
gcc_assert (type_annotate_only);
if (this_global)
force_global--;
return error_mark_node;
}
@ -670,11 +666,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
tree gnu_fat
= TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
tree gnu_temp_type
= TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat))));
gnu_type
= build_unc_object_type (gnu_temp_type, gnu_type,
= build_unc_object_type_from_ptr (gnu_fat, gnu_type,
concat_id_with_name (gnu_entity_id,
"UNC"));
}
@ -729,18 +723,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
/* See if this is a renaming. If this is a constant renaming, treat
it as a normal variable whose initial value is what is being
renamed. We cannot do this if the type is unconstrained or
class-wide.
/* See if this is a renaming, and handle appropriately depending on
what is renamed and in which context. There are three major
cases:
Otherwise, if what we are renaming is a reference, we can simply
return a stabilized version of that reference, after forcing any
SAVE_EXPRs to be evaluated. But, if this is at global level, we
can only do this if we know no SAVE_EXPRs will be made.
1/ This is a constant renaming and we can just make an object
with what is renamed as its initial value,
Otherwise, make this into a constant pointer to the object we are
to rename. */
2/ We can reuse a stabilized version of what is renamed in place
of the renaming,
3/ If neither 1 or 2 applies, we make the renaming entity a constant
pointer to what is being renamed. */
if (Present (Renamed_Object (gnat_entity)))
{
@ -756,6 +750,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_type = TREE_TYPE (gnu_expr);
}
/* Case 1: If this is a constant renaming, treat it as a normal
object whose initial value is what is being renamed. We cannot
do this if the type is unconstrained or class-wide. */
if (const_flag
&& !TREE_SIDE_EFFECTS (gnu_expr)
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
@ -764,49 +761,100 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& !Is_Array_Type (Etype (gnat_entity)))
;
/* If this is a declaration or reference that we can stabilize,
just use that declaration or reference as this entity unless
the latter has to be materialized. */
else if ((DECL_P (gnu_expr) || REFERENCE_CLASS_P (gnu_expr))
&& !Materialize_Entity (gnat_entity)
&& (!global_bindings_p ()
|| (staticp (gnu_expr)
&& !TREE_SIDE_EFFECTS (gnu_expr))))
{
gnu_decl = gnat_stabilize_reference (gnu_expr, true);
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
break;
}
/* Otherwise, make this into a constant pointer to the object we
are to rename and attach the object to the pointer. We need
to stabilize too since the renaming evaluation may directly
reference the renamed object instead of the pointer we will
attach it to. We don't want variables in the expression to
be evaluated every time the renaming is used, since their
value may change in between. */
/* Otherwise, see if we can proceed with a stabilized version of
the renamed entity or if we need to make a pointer. */
else
{
bool has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
inner_const_flag = TREE_READONLY (gnu_expr);
const_flag = true;
gnu_type = build_reference_type (gnu_type);
renamed_obj = gnat_stabilize_reference (gnu_expr, true);
gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
bool stabilized;
tree maybe_stable_expr = NULL_TREE;
if (!global_bindings_p ())
/* Case 2: If the renaming entity need not be materialized and
the renamed expression is something we can stabilize, use
that for the renaming after forcing the evaluation of any
SAVE_EXPR. At the global level, we can only do this if we
know no SAVE_EXPRs will be made. */
if (!Materialize_Entity (gnat_entity)
&& (!global_bindings_p ()
|| (staticp (gnu_expr)
&& !TREE_SIDE_EFFECTS (gnu_expr))))
{
/* If the original expression had side effects, put a
SAVE_EXPR around this whole thing. */
if (has_side_effects)
gnu_expr = save_expr (gnu_expr);
maybe_stable_expr
= maybe_stabilize_reference (gnu_expr, true, false,
&stabilized);
add_stmt (gnu_expr);
if (stabilized)
{
gnu_decl = maybe_stable_expr;
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
break;
}
/* The stabilization failed. Keep maybe_stable_expr
untouched here to let the pointer case below know
about that failure. */
}
gnu_size = NULL_TREE;
used_by_ref = true;
/* Case 3: Make this into a constant pointer to the object we
are to rename and attach the object to the pointer if it is
an lvalue that can be stabilized.
From the proper scope, attached objects will be referenced
directly instead of indirectly via the pointer to avoid
subtle aliasing problems with non addressable entities.
They have to be stable because we must not evaluate the
variables in the expression every time the renaming is used.
They also have to be lvalues because the context in which
they are reused sometimes requires so. We call pointers
with an attached object "renaming" pointers.
In the rare cases where we cannot stabilize the renamed
object, we just make a "bare" pointer, and the renamed
entity is always accessed indirectly through it. */
{
bool has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
inner_const_flag = TREE_READONLY (gnu_expr);
const_flag = true;
gnu_type = build_reference_type (gnu_type);
/* If a previous attempt at unrestricted
stabilization failed, there is no point trying
again and we can reuse the result without
attaching it to the pointer. */
if (maybe_stable_expr)
;
/* Otherwise, try to stabilize now, restricting to
lvalues only, and attach the expression to the pointer
if the stabilization succeeds. */
else
{
maybe_stable_expr
= maybe_stabilize_reference (gnu_expr, true, true,
&stabilized);
if (stabilized)
renamed_obj = maybe_stable_expr;
/* Attaching is actually performed downstream, as soon
as we have a DECL for the pointer we make. */
}
gnu_expr
= build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
if (!global_bindings_p ())
{
/* If the original expression had side effects, put a
SAVE_EXPR around this whole thing. */
if (has_side_effects)
gnu_expr = save_expr (gnu_expr);
add_stmt (gnu_expr);
}
gnu_size = NULL_TREE;
used_by_ref = true;
}
}
}
@ -894,10 +942,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
imported. */
if ((!definition && Present (Address_Clause (gnat_entity)))
|| (Is_Imported (gnat_entity)
&& Convention (gnat_entity) == Convention_Stdcall))
&& Has_Stdcall_Convention (gnat_entity)))
{
gnu_type = build_reference_type (gnu_type);
gnu_size = NULL_TREE;
gnu_expr = NULL_TREE;
/* No point in taking the address of an initializing expression
that isn't going to be used. */
used_by_ref = true;
}
@ -1495,19 +1548,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_READONLY (gnu_template_type) = 1;
/* Make a node for the array. If we are not defining the array
suppress expanding incomplete types and save the node as the type
for GNAT_ENTITY. */
suppress expanding incomplete types. */
gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
if (!definition)
{
defer_incomplete_level++;
this_deferred = this_made_decl = true;
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, false);
saved = true;
}
defer_incomplete_level++, this_deferred = true;
/* Build the fat pointer type. Use a "void *" object instead of
a pointer to the array type since we don't have the array type
@ -2310,9 +2355,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
/* Make a node for the record. If we are not defining the record,
suppress expanding incomplete types and save the node as the type
for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type
and reset TYPE_DUMMY_P to show it's no longer a dummy.
suppress expanding incomplete types. We use the same RECORD_TYPE
as for a dummy type and reset TYPE_DUMMY_P to show it's no longer
a dummy.
It is very tempting to delay resetting this bit until we are done
with completing the type, e.g. to let possible intermediate
@ -2335,15 +2380,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_PACKED (gnu_type) = packed || has_rep;
if (!definition)
{
defer_incomplete_level++;
this_deferred = true;
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, false);
this_made_decl = saved = true;
}
defer_incomplete_level++, this_deferred = true;
/* If both a size and rep clause was specified, put the size in
the record type now so that it can get the proper mode. */
@ -3642,8 +3679,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (list_length (gnu_return_list) == 1)
gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
#ifdef TARGET_DLLIMPORT_DECL_ATTRIBUTES
if (Convention (gnat_entity) == Convention_Stdcall)
if (Has_Stdcall_Convention (gnat_entity))
{
struct attrib *attr
= (struct attrib *) xmalloc (sizeof (struct attrib));
@ -3655,7 +3691,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
attr->error_point = gnat_entity;
attr_list = attr;
}
#endif
/* Both lists ware built in reverse. */
gnu_param_list = nreverse (gnu_param_list);
@ -3766,14 +3801,23 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
compiling, then just get the type from its Etype. */
if (No (Full_View (gnat_entity)))
{
/* If this is an incomplete type with no full view, it must
be a Taft Amendement type, so just return a dummy type. */
/* If this is an incomplete type with no full view, it must be
either a limited view brought in by a limited_with clause, in
which case we use the non-limited view, or a Taft Amendement
type, in which case we just return a dummy type. */
if (kind == E_Incomplete_Type)
gnu_type = make_dummy_type (gnat_entity);
{
if (From_With_Type (gnat_entity)
&& Present (Non_Limited_View (gnat_entity)))
gnu_decl = gnat_to_gnu_entity (Non_Limited_View (gnat_entity),
NULL_TREE, 0);
else
gnu_type = make_dummy_type (gnat_entity);
}
else if (Present (Underlying_Full_View (gnat_entity)))
gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
NULL_TREE, 0);
else if (Present (Underlying_Full_View (gnat_entity)))
gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
NULL_TREE, 0);
else
{
gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
@ -4087,7 +4131,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
DECL_ARTIFICIAL (gnu_decl) = 1;
if (!debug_info_p && DECL_P (gnu_decl)
&& TREE_CODE (gnu_decl) != FUNCTION_DECL)
&& TREE_CODE (gnu_decl) != FUNCTION_DECL
&& No (Renamed_Object (gnat_entity)))
DECL_IGNORED_P (gnu_decl) = 1;
/* If we haven't already, associate the ..._DECL node that we just made with
@ -4703,9 +4748,9 @@ elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
gnu_decl
= create_var_decl (create_concat_name (gnat_entity,
IDENTIFIER_POINTER (gnu_name)),
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true,
Is_Public (gnat_entity), !definition, false, NULL,
gnat_entity);
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
!need_debug, Is_Public (gnat_entity),
!definition, false, NULL, gnat_entity);
/* We only need to use this variable if we are in global context since GCC
can do the right thing in the local case. */
@ -5812,6 +5857,7 @@ annotate_value (tree gnu_size)
case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
case LT_EXPR: tcode = Lt_Expr; break;
case LE_EXPR: tcode = Le_Expr; break;
case GT_EXPR: tcode = Gt_Expr; break;
@ -5898,8 +5944,7 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type)
Set_Esize (gnat_field,
annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
}
else if (type_annotate_only
&& Is_Tagged_Type (gnat_entity)
else if (Is_Tagged_Type (gnat_entity)
&& Is_Derived_Type (gnat_entity))
{
/* If there is no gnu_entry, this is an inherited component whose
@ -6638,32 +6683,28 @@ rm_size (tree gnu_type)
tree
create_concat_name (Entity_Id gnat_entity, const char *suffix)
{
Entity_Kind kind = Ekind (gnat_entity);
const char *str = (!suffix ? "" : suffix);
String_Template temp = {1, strlen (str)};
Fat_Pointer fp = {str, &temp};
Get_External_Name_With_Suffix (gnat_entity, fp);
#ifdef TARGET_DLLIMPORT_DECL_ATTRIBUTES
/* A variable using the Stdcall convention (meaning we are running
on a Windows box) live in a DLL. Here we adjust its name to use
the jump-table, the _imp__NAME contains the address for the NAME
variable. */
{
Entity_Kind kind = Ekind (gnat_entity);
const char *prefix = "_imp__";
int plen = strlen (prefix);
if ((kind == E_Variable || kind == E_Constant)
&& Has_Stdcall_Convention (gnat_entity))
{
const char *prefix = "_imp__";
int k, plen = strlen (prefix);
if ((kind == E_Variable || kind == E_Constant)
&& Convention (gnat_entity) == Convention_Stdcall)
{
int k;
for (k = 0; k <= Name_Len; k++)
Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
strncpy (Name_Buffer, prefix, plen);
}
}
#endif
for (k = 0; k <= Name_Len; k++)
Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
strncpy (Name_Buffer, prefix, plen);
}
return get_identifier (Name_Buffer);
}

23
gcc/ada/gigi.h
View File

@ -248,9 +248,21 @@ extern void init_code_table (void);
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 an extra argument that says
whether to force evaluation of everything. */
/* 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);
/* Highest number in the front-end node table. */
@ -612,6 +624,11 @@ extern tree build_vms_descriptor (tree type, Mechanism_Type mech,
extern tree build_unc_object_type (tree template_type, tree object_type,
tree name);
/* Same as build_unc_object_type, but taking a thin or fat pointer type
instead of the template type. */
extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type,
tree object_type, tree name);
/* 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. */

143
gcc/ada/repinfo.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1999-2005 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- --
@ -48,6 +48,8 @@ with Table; use Table;
with Uname; use Uname;
with Urealp; use Urealp;
with Ada.Unchecked_Conversion;
package body Repinfo is
SSU : constant := 8;
@ -61,17 +63,16 @@ package body Repinfo is
-- Representation of gcc Expressions --
---------------------------------------
-- This table is used only if Frontend_Layout_On_Target is False,
-- so that gigi lays out dynamic size/offset fields using encoded
-- gcc expressions.
-- This table is used only if Frontend_Layout_On_Target is False, so that
-- gigi lays out dynamic size/offset fields using encoded gcc
-- expressions.
-- A table internal to this unit is used to hold the values of
-- back annotated expressions. This table is written out by -gnatt
-- and read back in for ASIS processing.
-- A table internal to this unit is used to hold the values of back
-- annotated expressions. This table is written out by -gnatt and read
-- back in for ASIS processing.
-- Node values are stored as Uint values which are the negative of
-- the node index in this table. Constants appear as non-negative
-- Uint values.
-- Node values are stored as Uint values using the negative of the node
-- index in this table. Constants appear as non-negative Uint values.
type Exp_Node is record
Expr : TCode;
@ -104,28 +105,27 @@ package body Repinfo is
-- Identifier casing for current unit
Need_Blank_Line : Boolean;
-- Set True if a blank line is needed before outputting any
-- information for the current entity. Set True when a new
-- entity is processed, and false when the blank line is output.
-- Set True if a blank line is needed before outputting any information for
-- the current entity. Set True when a new entity is processed, and false
-- when the blank line is output.
-----------------------
-- Local Subprograms --
-----------------------
function Back_End_Layout return Boolean;
-- Test for layout mode, True = back end, False = front end. This
-- function is used rather than checking the configuration parameter
-- because we do not want Repinfo to depend on Targparm (for ASIS)
-- Test for layout mode, True = back end, False = front end. This function
-- is used rather than checking the configuration parameter because we do
-- not want Repinfo to depend on Targparm (for ASIS)
procedure Blank_Line;
-- Called before outputting anything for an entity. Ensures that
-- a blank line precedes the output for a particular entity.
procedure List_Entities (Ent : Entity_Id);
-- This procedure lists the entities associated with the entity E,
-- starting with the First_Entity and using the Next_Entity link.
-- If a nested package is found, entities within the package are
-- recursively processed.
-- This procedure lists the entities associated with the entity E, starting
-- with the First_Entity and using the Next_Entity link. If a nested
-- package is found, entities within the package are recursively processed.
procedure List_Name (Ent : Entity_Id);
-- List name of entity Ent in appropriate case. The name is listed with
@ -135,8 +135,8 @@ package body Repinfo is
-- List representation info for array type Ent
procedure List_Mechanisms (Ent : Entity_Id);
-- List mechanism information for parameters of Ent, which is a
-- subprogram, subprogram type, or an entry or entry family.
-- List mechanism information for parameters of Ent, which is subprogram,
-- subprogram type, or an entry or entry family.
procedure List_Object_Info (Ent : Entity_Id);
-- List representation info for object Ent
@ -155,12 +155,11 @@ package body Repinfo is
-- Output given number of spaces
procedure Write_Info_Line (S : String);
-- Routine to write a line to Repinfo output file. This routine is
-- passed as a special output procedure to Output.Set_Special_Output.
-- Note that Write_Info_Line is called with an EOL character at the
-- end of each line, as per the Output spec, but the internal call
-- to the appropriate routine in Osint requires that the end of line
-- sequence be stripped off.
-- Routine to write a line to Repinfo output file. This routine is passed
-- as a special output procedure to Output.Set_Special_Output. Note that
-- Write_Info_Line is called with an EOL character at the end of each line,
-- as per the Output spec, but the internal call to the appropriate routine
-- in Osint requires that the end of line sequence be stripped off.
procedure Write_Mechanism (M : Mechanism_Type);
-- Writes symbolic string for mechanism represented by M
@ -168,8 +167,8 @@ package body Repinfo is
procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
-- Given a representation value, write it out. No_Uint values or values
-- dependent on discriminants are written as two question marks. If the
-- flag Paren is set, then the output is surrounded in parentheses if
-- it is other than a simple value.
-- flag Paren is set, then the output is surrounded in parentheses if it is
-- other than a simple value.
---------------------
-- Back_End_Layout --
@ -177,8 +176,8 @@ package body Repinfo is
function Back_End_Layout return Boolean is
begin
-- We have back end layout if the back end has made any entries in
-- the table of GCC expressions, otherwise we have front end layout.
-- We have back end layout if the back end has made any entries in the
-- table of GCC expressions, otherwise we have front end layout.
return Rep_Table.Last > 0;
end Back_End_Layout;
@ -350,10 +349,10 @@ package body Repinfo is
while Present (E) loop
Need_Blank_Line := True;
-- We list entities that come from source (excluding private
-- or incomplete types or deferred constants, where we will
-- list the info for the full view). If debug flag A is set,
-- then all entities are listed
-- We list entities that come from source (excluding private or
-- incomplete types or deferred constants, where we will list the
-- info for the full view). If debug flag A is set, then all
-- entities are listed
if (Comes_From_Source (E)
and then not Is_Incomplete_Or_Private_Type (E)
@ -402,10 +401,9 @@ package body Repinfo is
end if;
-- Recurse into nested package, but not if they are
-- package renamings (in particular renamings of the
-- enclosing package, as for some Java bindings and
-- for generic instances).
-- Recurse into nested package, but not if they are package
-- renamings (in particular renamings of the enclosing package,
-- as for some Java bindings and for generic instances).
if Ekind (E) = E_Package then
if No (Renamed_Object (E)) then
@ -438,10 +436,10 @@ package body Repinfo is
E := Next_Entity (E);
end loop;
-- For a package body, the entities of the visible subprograms
-- are declared in the corresponding spec. Iterate over its
-- entities in order to handle properly the subprogram bodies.
-- Skip bodies in subunits, which are listed independently.
-- For a package body, the entities of the visible subprograms are
-- declared in the corresponding spec. Iterate over its entities in
-- order to handle properly the subprogram bodies. Skip bodies in
-- subunits, which are listed independently.
if Ekind (Ent) = E_Package_Body
and then Present (Corresponding_Spec (Find_Declaration (Ent)))
@ -583,6 +581,9 @@ package body Repinfo is
Write_Str ("not ");
Print_Expr (Node.Op1);
when Bit_And_Expr =>
Binop (" & ");
when Lt_Expr =>
Binop (" < ");
@ -801,9 +802,9 @@ package body Repinfo is
UI_Image (Sunit);
end if;
-- If the record is not packed, then we know that all
-- fields whose position is not specified have a starting
-- normalized bit position of zero
-- If the record is not packed, then we know that all fields whose
-- position is not specified have a starting normalized bit
-- position of zero
if Unknown_Normalized_First_Bit (Comp)
and then not Is_Packed (Ent)
@ -885,11 +886,11 @@ package body Repinfo is
UI_Write (Fbit);
Write_Str (" .. ");
-- Allowing Uint_0 here is a kludge, really this should be
-- a fine Esize value but currently it means unknown, except
-- that we know after gigi has back annotated that a size of
-- zero is real, since otherwise gigi back annotates using
-- No_Uint as the value to indicate unknown).
-- Allowing Uint_0 here is a kludge, really this should be a
-- fine Esize value but currently it means unknown, except that
-- we know after gigi has back annotated that a size of zero is
-- real, since otherwise gigi back annotates using No_Uint as
-- the value to indicate unknown).
if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
and then Known_Static_Normalized_First_Bit (Comp)
@ -916,8 +917,8 @@ package body Repinfo is
Write_Val (Esiz, Paren => True);
-- If in front end layout mode, then dynamic size is
-- stored in storage units, so renormalize for output
-- If in front end layout mode, then dynamic size is stored
-- in storage units, so renormalize for output
if not Back_End_Layout then
Write_Str (" * ");
@ -1019,8 +1020,8 @@ package body Repinfo is
Write_Line (";");
-- For now, temporary case, to be removed when gigi properly back
-- annotates RM_Size, if RM_Size is not set, then list Esize as
-- Size. This avoids odd Object_Size output till we fix things???
-- annotates RM_Size, if RM_Size is not set, then list Esize as Size.
-- This avoids odd Object_Size output till we fix things???
elsif Unknown_RM_Size (Ent) then
Write_Str ("for ");
@ -1086,6 +1087,14 @@ package body Repinfo is
function V (Val : Node_Ref_Or_Val) return Uint;
-- Internal recursive routine to evaluate tree
function W (Val : Uint) return Word;
-- Convert Val to Word, assuming Val is always in the Int range. This is
-- a helper function for the evaluation of bitwise expressions like
-- Bit_And_Expr, for which there is no direct support in uintp. Uint
-- values out of the Int range are expected to be seen in such
-- expressions only with overflowing byte sizes around, introducing
-- inherent unreliabilties in computations anyway.
-------
-- B --
-------
@ -1112,6 +1121,23 @@ package body Repinfo is
end if;
end T;
-------
-- W --
-------
-- We use an unchecked conversion to map Int values to their Word
-- bitwise equivalent, which we could not achieve with a normal type
-- conversion for negative Ints. We want bitwise equivalents because W
-- is used as a helper for bit operators like Bit_And_Expr, and can be
-- called for negative Ints in the context of aligning expressions like
-- X+Align & -Align.
function W (Val : Uint) return Word is
function To_Word is new Ada.Unchecked_Conversion (Int, Word);
begin
return To_Word (UI_To_Int (Val));
end W;
-------
-- V --
-------
@ -1203,6 +1229,11 @@ package body Repinfo is
when Truth_Not_Expr =>
return B (not T (Node.Op1));
when Bit_And_Expr =>
L := V (Node.Op1);
R := V (Node.Op2);
return UI_From_Int (Int (W (L) and W (R)));
when Lt_Expr =>
return B (V (Node.Op1) < V (Node.Op2));

7
gcc/ada/repinfo.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1999-2005, 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- --
@ -35,7 +35,7 @@
-- tree to fill in representation information, and also the routine used
-- by -gnatR to print this information. This unit is used both in the
-- compiler and in ASIS (it is used in ASIS as part of the implementation
-- of the data decomposition annex.
-- of the data decomposition annex).
with Types; use Types;
with Uintp; use Uintp;
@ -128,7 +128,7 @@ package Repinfo is
-- Subtype used for values that can either be a Node_Ref (negative)
-- or a value (non-negative)
type TCode is range 0 .. 27;
type TCode is range 0 .. 28;
-- Type used on Ada side to represent DEFTREECODE values defined in
-- tree.def. Only a subset of these tree codes can actually appear.
-- The names are the names from tree.def in Ada casing.
@ -162,6 +162,7 @@ package Repinfo is
Ge_Expr : constant TCode := 25; -- comparision >= 2
Eq_Expr : constant TCode := 26; -- comparision = 2
Ne_Expr : constant TCode := 27; -- comparision /= 2
Bit_And_Expr : constant TCode := 28; -- Binary and 2
-- The following entry is used to represent a discriminant value in
-- the tree. It has a special tree code that does not correspond

3
gcc/ada/repinfo.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1999-2002 Free Software Foundation, Inc. *
* Copyright (C) 1999-2005 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- *
@ -67,6 +67,7 @@ typedef char TCode;
#define Ge_Expr 25
#define Eq_Expr 26
#define Ne_Expr 27
#define Bit_And_Expr 28
/* Creates a node using the tree code defined by Expr and from 1-3
operands as required (unused operands set as shown to No_Uint) Note

186
gcc/ada/trans.c
View File

@ -408,13 +408,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
else if (TREE_CODE (gnu_result) == VAR_DECL
&& (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0
&& (! DECL_RENAMING_GLOBAL_P (gnu_result)
|| global_bindings_p ())
/* Make sure it's an lvalue like INDIRECT_REF. */
&& (DECL_P (renamed_obj)
|| REFERENCE_CLASS_P (renamed_obj)
|| (TREE_CODE (renamed_obj) == VIEW_CONVERT_EXPR
&& (DECL_P (TREE_OPERAND (renamed_obj, 0))
|| REFERENCE_CLASS_P (TREE_OPERAND (renamed_obj,0))))))
|| global_bindings_p ()))
gnu_result = renamed_obj;
else
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
@ -719,6 +713,21 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
= size_binop (MAX_EXPR, gnu_result,
DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
}
else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
{
Node_Id gnat_deref = Prefix (gnat_node);
Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
&& Present (gnat_actual_subtype))
{
tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type, get_identifier ("SIZE"));
}
gnu_result = TYPE_SIZE (gnu_type);
}
else
gnu_result = TYPE_SIZE (gnu_type);
}
@ -1564,8 +1573,15 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
0, Etype (Name (gnat_node)), "PAD", false,
false, false);
gnu_target = create_tmp_var_raw (gnu_obj_type, "LR");
gnat_pushdecl (gnu_target, gnat_node);
/* ??? We may be about to create a static temporary if we happen to
be at the global binding level. That's a regression from what
the 3.x back-end would generate in the same situation, but we
don't have a mechanism in Gigi for creating automatic variables
in the elaboration routines. */
gnu_target
= create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
NULL, false, false, false, false, NULL,
gnat_node);
}
gnu_actual_list
@ -1602,6 +1618,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
tree gnu_formal
= (present_gnu_tree (gnat_formal)
? get_gnu_tree (gnat_formal) : NULL_TREE);
tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
/* We treat a conversion between aggregate types as if it is an
unchecked conversion. */
bool unchecked_convert_p
@ -1613,7 +1630,6 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
tree gnu_name = gnat_to_gnu (gnat_name);
tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
tree gnu_actual;
tree gnu_formal_type;
/* If it's possible we may need to use this expression twice, make sure
than any side-effects are handled via SAVE_EXPRs. Likewise if we need
@ -1626,6 +1642,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
if (Ekind (gnat_formal) != E_In_Parameter)
{
gnu_name = gnat_stabilize_reference (gnu_name, true);
if (!addressable_p (gnu_name)
&& gnu_formal
&& (DECL_BY_REF_P (gnu_formal)
@ -1741,6 +1758,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
gnu_actual);
if (TREE_CODE (gnu_actual) != SAVE_EXPR)
gnu_actual = convert (gnu_formal_type, gnu_actual);
/* If we have not saved a GCC object for the formal, it means it is an
OUT parameter not passed by reference and that does not need to be
copied in. Otherwise, look at the PARM_DECL to see if it is passed by
@ -1989,7 +2009,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
&& TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
}
gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_actual, gnu_result);
annotate_with_node (gnu_result, gnat_actual);
@ -2497,25 +2517,40 @@ gnat_to_gnu (Node_Id gnat_node)
return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
build_call_raise (CE_Range_Check_Failed));
/* 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 context. */
if (!current_function_decl
&& ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
&& Nkind (gnat_node) != N_Null_Statement)
|| Nkind (gnat_node) == N_Procedure_Call_Statement
|| Nkind (gnat_node) == N_Label
|| Nkind (gnat_node) == N_Implicit_Label_Declaration
|| Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
|| ((Nkind (gnat_node) == N_Raise_Constraint_Error
|| Nkind (gnat_node) == N_Raise_Storage_Error
|| Nkind (gnat_node) == N_Raise_Program_Error)
&& (Ekind (Etype (gnat_node)) == E_Void))))
/* 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
context.
If we are in the elaboration procedure, check if we are violating a a
No_Elaboration_Code restriction by having a statement there. */
if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
&& Nkind (gnat_node) != N_Null_Statement)
|| Nkind (gnat_node) == N_Procedure_Call_Statement
|| Nkind (gnat_node) == N_Label
|| Nkind (gnat_node) == N_Implicit_Label_Declaration
|| Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
|| ((Nkind (gnat_node) == N_Raise_Constraint_Error
|| Nkind (gnat_node) == N_Raise_Storage_Error
|| Nkind (gnat_node) == N_Raise_Program_Error)
&& (Ekind (Etype (gnat_node)) == E_Void)))
{
current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
start_stmt_group ();
gnat_pushlevel ();
went_into_elab_proc = true;
if (!current_function_decl)
{
current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
start_stmt_group ();
gnat_pushlevel ();
went_into_elab_proc = true;
}
/* Don't check for a possible No_Elaboration_Code restriction violation
on N_Handled_Sequence_Of_Statements, as we want to signal an error on
every nested real statement instead. This also avoids triggering
spurious errors on dummy (empty) sequences created by the front-end
for package bodies in some cases. */
if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
&& Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
Check_Elaboration_Code_Allowed (gnat_node);
}
switch (Nkind (gnat_node))
@ -2982,7 +3017,7 @@ gnat_to_gnu (Node_Id gnat_node)
? Designated_Type (Etype
(Prefix (gnat_node)))
: Etype (Prefix (gnat_node))))
gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
gnu_result
= build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
@ -3427,7 +3462,7 @@ gnat_to_gnu (Node_Id gnat_node)
/* If the type has a size that overflows, convert this into raise of
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))))
&& TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
gnu_result = build_call_raise (SE_Object_Too_Large);
else if (Nkind (Expression (gnat_node)) == N_Function_Call
&& !Do_Range_Check (Expression (gnat_node)))
@ -3927,7 +3962,9 @@ gnat_to_gnu (Node_Id gnat_node)
if (!type_annotate_only)
{
tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
tree gnu_obj_type;
tree gnu_actual_obj_type = 0;
tree gnu_obj_size;
int align;
@ -3952,7 +3989,21 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_ptr);
gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
if (Present (Actual_Designated_Subtype (gnat_node)))
{
gnu_actual_obj_type = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
gnu_actual_obj_type
= build_unc_object_type_from_ptr (gnu_ptr_type,
gnu_actual_obj_type,
get_identifier ("DEALLOC"));
}
else
gnu_actual_obj_type = gnu_obj_type;
gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
align = TYPE_ALIGN (gnu_obj_type);
if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
@ -4106,7 +4157,7 @@ gnat_to_gnu (Node_Id gnat_node)
if (TREE_SIDE_EFFECTS (gnu_result)
&& (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
|| CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
gnu_result = gnat_stabilize_reference (gnu_result, 0);
gnu_result = gnat_stabilize_reference (gnu_result, false);
/* Now convert the result to the proper type. If the type is void or if
we have no result, return error_mark_node to show we have no result.
@ -5709,17 +5760,26 @@ protect_multiple_eval (tree exp)
exp)));
}
/* This is equivalent to stabilize_reference in GCC's tree.c, but we know
how to handle our new nodes and we take an extra argument that says
whether to force evaluation of everything. */
/* 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. */
tree
gnat_stabilize_reference (tree ref, bool force)
maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
bool *success)
{
tree type = TREE_TYPE (ref);
enum tree_code code = TREE_CODE (ref);
tree result;
/* Assume we'll success unless proven otherwise. */
*success = true;
switch (code)
{
case VAR_DECL:
@ -5728,6 +5788,15 @@ gnat_stabilize_reference (tree ref, bool force)
/* No action is needed in this case. */
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 INDIREC_REF goes
straight to stabilize_1. */
if (lvalues_only)
goto failure;
/* ... Fallthru ... */
case NOP_EXPR:
case CONVERT_EXPR:
case FLOAT_EXPR:
@ -5736,10 +5805,10 @@ gnat_stabilize_reference (tree ref, bool force)
case FIX_ROUND_EXPR:
case FIX_CEIL_EXPR:
case VIEW_CONVERT_EXPR:
case ADDR_EXPR:
result
= build1 (code, type,
gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
lvalues_only, success));
break;
case INDIRECT_REF:
@ -5750,15 +5819,16 @@ gnat_stabilize_reference (tree ref, bool force)
break;
case COMPONENT_REF:
result = build3 (COMPONENT_REF, type,
gnat_stabilize_reference (TREE_OPERAND (ref, 0),
force),
TREE_OPERAND (ref, 1), NULL_TREE);
result = build3 (COMPONENT_REF, type,
maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
lvalues_only, success),
TREE_OPERAND (ref, 1), NULL_TREE);
break;
case BIT_FIELD_REF:
result = build3 (BIT_FIELD_REF, type,
gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
lvalues_only, success),
gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
force),
gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
@ -5768,7 +5838,8 @@ gnat_stabilize_reference (tree ref, bool force)
case ARRAY_REF:
case ARRAY_RANGE_REF:
result = build4 (code, type,
gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
lvalues_only, success),
gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
force),
NULL_TREE, NULL_TREE);
@ -5778,17 +5849,21 @@ gnat_stabilize_reference (tree ref, bool force)
result = build2 (COMPOUND_EXPR, type,
gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
force),
gnat_stabilize_reference (TREE_OPERAND (ref, 1),
force));
maybe_stabilize_reference (TREE_OPERAND (ref, 1), force,
lvalues_only, success));
break;
case ERROR_MARK:
ref = error_mark_node;
/* ... Fallthru to failure ... */
/* 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;
case ERROR_MARK:
return error_mark_node;
}
TREE_READONLY (result) = TREE_READONLY (ref);
@ -5808,6 +5883,17 @@ gnat_stabilize_reference (tree ref, bool force)
return result;
}
/* Wrapper around maybe_stabilize_reference, for common uses without
lvalue restrictions and without need to examine the success
indication. */
tree
gnat_stabilize_reference (tree ref, bool force)
{
bool stabilized;
return maybe_stabilize_reference (ref, force, false, &stabilized);
}
/* Similar to stabilize_reference_1 in tree.c, but supports an extra
arg to force a SAVE_EXPR for everything. */

100
gcc/ada/utils.c
View File

@ -324,7 +324,13 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
DECL_CONTEXT (decl) = 0;
else
DECL_CONTEXT (decl) = current_function_decl;
{
DECL_CONTEXT (decl) = current_function_decl;
/* Functions imported in another function are not really nested. */
if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl))
DECL_NO_STATIC_CHAIN (decl) = 1;
}
TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node));
@ -1277,6 +1283,12 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
|| (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
var_init = NULL_TREE;
/* At the global level, an initializer requiring code to be generated
produces elaboration statements. Check that such statements are allowed,
that is, not violating a No_Elaboration_Code restriction. */
if (global_bindings_p () && var_init != 0 && ! init_const)
Check_Elaboration_Code_Allowed (gnat_node);
/* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
try to fiddle with DECL_COMMON. However, on platforms that don't
support global BSS sections, uninitialized global variables would
@ -1313,6 +1325,10 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
if (TREE_CODE (var_decl) != CONST_DECL)
rest_of_decl_compilation (var_decl, global_bindings_p (), 0);
else
/* expand CONST_DECLs to set their MODE, ALIGN, SIZE and SIZE_UNIT,
which we need for later back-annotations. */
expand_decl (var_decl);
return var_decl;
}
@ -1607,7 +1623,7 @@ potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
% DECL_ALIGN (curr_field) != 0);
/* If both the position and size of the previous field are multiples
of the current field alignment, there can not be any gap. */
of the current field alignment, there cannot be any gap. */
if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
&& value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
return false;
@ -2444,6 +2460,22 @@ build_unc_object_type (tree template_type, tree object_type, tree name)
return type;
}
/* Same, taking a thin or fat pointer type instead of a template type. */
tree
build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, tree name)
{
tree template_type;
gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
template_type
= (TYPE_FAT_POINTER_P (thin_fat_ptr_type)
? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (thin_fat_ptr_type))))
: TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type))));
return build_unc_object_type (template_type, object_type, name);
}
/* 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
@ -2755,11 +2787,15 @@ convert (tree type, tree expr)
expr)),
TYPE_MIN_VALUE (etype))));
/* If the input is a justified modular type, we need to extract
the actual object before converting it to any other type with the
exception of an unconstrained array. */
/* If the input is a justified modular type, we need to extract the actual
object before converting it to any other type with the exceptions of an
unconstrained array or of a mere type variant. It is useful to avoid the
extraction and conversion in the type variant case because it could end
up replacing a VAR_DECL expr by a constructor and we might be about the
take the address of the result. */
if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
&& code != UNCONSTRAINED_ARRAY_TYPE)
&& code != UNCONSTRAINED_ARRAY_TYPE
&& TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype))
return convert (type, build_component_ref (expr, NULL_TREE,
TYPE_FIELDS (etype), false));
@ -2804,9 +2840,7 @@ convert (tree type, tree expr)
just make a new one in the proper type. */
if (code == ecode && AGGREGATE_TYPE_P (etype)
&& !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
&& TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
&& (TREE_CODE (expr) == STRING_CST
|| get_alias_set (etype) == get_alias_set (type)))
&& TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
{
expr = copy_node (expr);
TREE_TYPE (expr) = type;
@ -2826,9 +2860,40 @@ convert (tree type, tree expr)
break;
case VIEW_CONVERT_EXPR:
if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
&& !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
return convert (type, TREE_OPERAND (expr, 0));
{
/* GCC 4.x is very sensitive to type consistency overall, and view
conversions thus are very frequent. Eventhough just "convert"ing
the inner operand to the output type is fine in most cases, it
might expose unexpected input/output type mismatches in special
circumstances so we avoid such recursive calls when we can. */
tree op0 = TREE_OPERAND (expr, 0);
/* If we are converting back to the original type, we can just
lift the input conversion. This is a common occurence with
switches back-and-forth amongst type variants. */
if (type == TREE_TYPE (op0))
return op0;
/* Otherwise, if we're converting between two aggregate types, we
might be allowed to substitute the VIEW_CONVERT target type in
place or to just convert the inner expression. */
if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
{
/* If we are converting between type variants, we can just
substitute the VIEW_CONVERT in place. */
if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
return build1 (VIEW_CONVERT_EXPR, type, op0);
/* Otherwise, we may just bypass the input view conversion unless
one of the types is a fat pointer, or we're converting to an
unchecked union type. Both are handled by specialized code
below and the latter relies on exact type matching. */
else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)
&& !(code == UNION_TYPE && TYPE_UNCHECKED_UNION_P (type)))
return convert (type, op0);
}
}
break;
case INDIRECT_REF:
@ -2957,13 +3022,10 @@ convert (tree type, tree expr)
{
if (TREE_TYPE (tem) == etype)
return build1 (CONVERT_EXPR, type, expr);
/* Accept slight type variations. */
if (TREE_TYPE (tem) == TYPE_MAIN_VARIANT (etype)
|| (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
&& (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
|| TYPE_IS_PADDING_P (TREE_TYPE (tem)))
&& TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype))
else if (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
&& (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
|| TYPE_IS_PADDING_P (TREE_TYPE (tem)))
&& TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype)
return build1 (CONVERT_EXPR, type,
convert (TREE_TYPE (tem), expr));
}

129
gcc/ada/utils2.c
View File

@ -170,7 +170,7 @@ known_alignment (tree exp)
case NON_LVALUE_EXPR:
/* Conversions between pointers and integers don't change the alignment
of the underlying object. */
this_alignment = known_alignment (TREE_OPERAND (exp, 0));
this_alignment = known_alignment (TREE_OPERAND (exp, 0));
break;
case PLUS_EXPR:
@ -656,40 +656,6 @@ build_binary_op (enum tree_code op_code, tree result_type,
if (!operation_type)
operation_type = left_type;
/* If the RHS has a conversion between record and array types and
an inner type is no worse, use it. Note we cannot do this for
modular types or types with TYPE_ALIGN_OK, since the latter
might indicate a conversion between a root type and a class-wide
type, which we must not remove. */
while (TREE_CODE (right_operand) == VIEW_CONVERT_EXPR
&& (((TREE_CODE (right_type) == RECORD_TYPE
|| TREE_CODE (right_type) == UNION_TYPE)
&& !TYPE_JUSTIFIED_MODULAR_P (right_type)
&& !TYPE_ALIGN_OK (right_type)
&& !TYPE_IS_FAT_POINTER_P (right_type))
|| TREE_CODE (right_type) == ARRAY_TYPE)
&& ((((TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== RECORD_TYPE)
|| (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== UNION_TYPE))
&& !(TYPE_JUSTIFIED_MODULAR_P
(TREE_TYPE (TREE_OPERAND (right_operand, 0))))
&& !(TYPE_ALIGN_OK
(TREE_TYPE (TREE_OPERAND (right_operand, 0))))
&& !(TYPE_IS_FAT_POINTER_P
(TREE_TYPE (TREE_OPERAND (right_operand, 0)))))
|| (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== ARRAY_TYPE))
&& (0 == (best_type
= find_common_type (right_type,
TREE_TYPE (TREE_OPERAND
(right_operand, 0))))
|| right_type != best_type))
{
right_operand = TREE_OPERAND (right_operand, 0);
right_type = TREE_TYPE (right_operand);
}
/* If we are copying one array or record to another, find the best type
to use. */
if (((TREE_CODE (left_type) == ARRAY_TYPE
@ -1159,12 +1125,18 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand)
return build_unary_op (ADDR_EXPR, result_type,
TREE_OPERAND (operand, 0));
/* If this NOP_EXPR doesn't change the mode, get the result type
from this type and go down. We need to do this in case
this is a conversion of a CONST_DECL. */
if (TYPE_MODE (type) != BLKmode
&& (TYPE_MODE (type)
== TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0)))))
/* ... fallthru ... */
case VIEW_CONVERT_EXPR:
/* If this just a variant conversion or if the conversion doesn't
change the mode, get the result type from this type and go down.
This is needed for conversions of CONST_DECLs, to eventually get
to the address of their CORRESPONDING_VARs. */
if ((TYPE_MAIN_VARIANT (type)
== TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0))))
|| (TYPE_MODE (type) != BLKmode
&& (TYPE_MODE (type)
== TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))))
return build_unary_op (ADDR_EXPR,
(result_type ? result_type
: build_pointer_type (type)),
@ -1409,7 +1381,7 @@ build_return_expr (tree result_decl, tree ret_val)
build_binary_op with the additional guarantee that the type
cannot involve a placeholder, since otherwise the function
would use the "target pointer" return mechanism. */
if (operation_type != TREE_TYPE (ret_val))
ret_val = convert (operation_type, ret_val);
@ -1493,17 +1465,41 @@ build_call_raise (int msg)
build_int_cst (NULL_TREE, input_line));
}
/* qsort comparer for the bit positions of two constructor elements
for record components. */
static int
compare_elmt_bitpos (const PTR rt1, const PTR rt2)
{
tree elmt1 = * (tree *) rt1;
tree elmt2 = * (tree *) rt2;
tree pos_field1 = bit_position (TREE_PURPOSE (elmt1));
tree pos_field2 = bit_position (TREE_PURPOSE (elmt2));
if (tree_int_cst_equal (pos_field1, pos_field2))
return 0;
else if (tree_int_cst_lt (pos_field1, pos_field2))
return -1;
else
return 1;
}
/* Return a CONSTRUCTOR of TYPE whose list is LIST. */
tree
gnat_build_constructor (tree type, tree list)
{
tree elmt;
int n_elmts;
bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
bool side_effects = false;
tree result;
for (elmt = list; elmt; elmt = TREE_CHAIN (elmt))
/* Scan the elements to see if they are all constant or if any has side
effects, to let us set global flags on the resulting constructor. Count
the elements along the way for possible sorting purposes below. */
for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++)
{
if (!TREE_CONSTANT (TREE_VALUE (elmt))
|| (TREE_CODE (type) == RECORD_TYPE
@ -1525,26 +1521,30 @@ gnat_build_constructor (tree type, tree list)
return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0));
}
/* If TYPE is a RECORD_TYPE and the fields are not in the
same order as their bit position, don't treat this as constant
since varasm.c can't handle it. */
if (allconstant && TREE_CODE (type) == RECORD_TYPE)
/* For record types with constant components only, sort field list
by increasing bit position. This is necessary to ensure the
constructor can be output as static data, which the gimplifier
might force in various circumstances. */
if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
{
tree last_pos = bitsize_zero_node;
tree field;
/* Fill an array with an element tree per index, and ask qsort to order
them according to what a bitpos comparison function says. */
for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
int i;
for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++)
gnu_arr[i] = elmt;
qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
/* Then reconstruct the list from the sorted array contents. */
list = NULL_TREE;
for (i = n_elmts - 1; i >= 0; i--)
{
tree this_pos = bit_position (field);
if (TREE_CODE (this_pos) != INTEGER_CST
|| tree_int_cst_lt (this_pos, last_pos))
{
allconstant = false;
break;
}
last_pos = this_pos;
TREE_CHAIN (gnu_arr[i]) = list;
list = gnu_arr[i];
}
}
@ -1821,13 +1821,10 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
fill in the parts that are known. */
else if (TYPE_FAT_OR_THIN_POINTER_P (result_type))
{
tree template_type
= (TYPE_FAT_POINTER_P (result_type)
? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (result_type))))
: TREE_TYPE (TYPE_FIELDS (TREE_TYPE (result_type))));
tree storage_type
= build_unc_object_type (template_type, type,
get_identifier ("ALLOC"));
= build_unc_object_type_from_ptr (result_type, type,
get_identifier ("ALLOC"));
tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
tree storage_ptr_type = build_pointer_type (storage_type);
tree storage;
tree template_cons = NULL_TREE;