Skip to content

R
riscv-gcc-1
Commit f2cbd970 by Javier Miranda Committed by Arnaud Charlet
Options

a-tags.adb (Register_Interface_Offset): New subprogram. 

2008-04-08  Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* a-tags.adb (Register_Interface_Offset): New subprogram.
	(Set_Dynamic_Offset_To_Top): New subprogram (see previous comment).
	(To_Predef_Prims_Table_Ptr): Removed.
	(Acc_Size): Removed.
	(To_Acc_Size): Removed.
	(Parent_Size): Modified to the call the subprogram returning the size of
	the parent by means of the new TSD component Size_Func.

	* a-tags.ads (Offset_To_Top_Ptr): New access type declaration.
	(DT_Offset_To_Top_Offset): New constant value that is used to generate
	code referencing the Offset_To_Top component of the dispatch table's
	prologue.
	(Prim_Ptr): New declaration of access to procedure. Used to avoid the
	use of 'address to initialize dispatch table slots.
	(Size_Func): New component of the TSD. Used by the run-time to call the
	size primitive of the tagged type.

	* checks.adb (Apply_Access_Check): Avoid check when accessing the
	Offset_To_Top component of a dispatch table.
	(Null_Exclusion_Static_Checks): If the non-null access type appears in a
	deferred constant declaration. do not add a null expression, to prevent
	spurious errors when full declaration is analyzed.
	(Apply_Discriminant_Check): If both discriminant constraints share a
	node which is not static but has no side effects, do not generate a
	check for that discriminant.
	(Generate_Index_Checks): Set Name_Req to true in call to duplicate
	subexpr, since the prefix of an attribute is a name.

	* checks.ads: Fix nit in comment.

	* exp_ch3.ads, exp_ch3.adb (Freeze_Record_Type): Do not add the spec
	and body of predefined primitives in case of CPP tagged type
	derivations.
	(Freeze_Type): Deal properly with no storage pool case
	(Make_Predefined_Primitive_Specs): Generate specification of abstract
	primitive Deep_Adjust if a nonlimited interface is derived from a
	limited interface.
	(Build_Dcheck_Functions): Create discriminant-checking functions only
	for variants that have some component(s).
	(Build_Slice_Assignment): In expanded code for slice assignment, handle
	properly the case where the slice bounds extend to the last value of the
	underlying representation.
	(Get_Simple_Init_Val): New calling sequence, accomodate Invalid_Value
	(Is_Variable_Size_Record): An array component has a static size if
	index bounds are enumeration literals.

	* exp_disp.adb (Make_DT): Use the first subtype to determine whether
	an external tag has been specified for the type.
	(Building_Static_DT): Add missing support for private types.
	(Make_DT): Add declaration of Parent_Typ to ensure consistent access
	to the entity associated with the parent of Typ. This is done to
	avoid wrong access when the parent is a private type.
	(Expand_Interface_Conversion): Improve error message when the
	configurable runtime has no support for dynamic interface conversion.
	(Expand_Interface_Thunk): Add missing support to interface types in
	configurable runtime.
	(Expand_Dispatching_Call): remove obsolete code.
	(Make_DT): Replace occurrences of RE_Address by RE_Prim_Ptr, and
	ensure that all subtypes and aggregates associated with dispatch
	tables have the attribute Is_Dispatch_Table_Entity set to true.
	(Register_Primitive): Rename one variable to improve code reading.
	Replace occurrences of RE_Addres by RE_Prim_Ptr. Register copy o
	of the pointer to the 'size primitive in the TSD.

	* rtsfind.ads (RE_DT_Offset_To_Top_Offset): New entity.
	(RE_Offset_To_Top_Ptr): New entity.
	(RE_Register_Interface_Offset): New entity.
	(RE_Set_Dynamic_Offset_To_Top): New entity.
	(RE_Set_Offset_To_Top): Removed entity.
	(RE_Prim_Ptr): New entity
	(RE_Size_Func): New entity
	(RE_Size_Ptr): New entity
	(RTU_Id): Add Ada_Dispatching and Ada_Dispatching_EDF.
	(Ada_Dispatching_Child): Define this new subrange.
	(RE_Id): Add new required run-time calls (RE_Set_Deadline, RE_Clock,
	 RE_Time_Span, and RE_Time_Span_Zero).
	(RE_Unit_Table): Add new required run-time calls

	* rtsfind.adb (Get_Unit_Name): Add processing for Ada.Dispatching
	children.

	* exp_atag.ads, exp_atag.adb (Build_Offset_To_Top): New subprogram.
	(Build_Set_Static_Offset_To_Top): New subprogram. Generates code that
	 initializes the Offset_To_Top component of a dispatch table.
	(Build_Predef_Prims): Removed.
	(Build_Get_Predefined_Prim_Op_Address): Replace call to Predef_Prims by
	 its actual code.
	(Build_Set_Size_Function): New subprogram.

	* exp_ch13.adb: Do not generate storage variable for storage_size zero
	(Expand): Handle setting/restoring flag Inside_Freezing_Actions

From-SVN: r134020
parent 868e30a5
Showing with 358 additions and 185 deletions
gcc/ada/a-tags.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -105,25 +105,12 @@ package body Ada.Tags is ...@@ -105,25 +105,12 @@ package body Ada.Tags is
function To_Object_Specific_Data_Ptr is function To_Object_Specific_Data_Ptr is
new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
function To_Predef_Prims_Table_Ptr is
new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr);
function To_Tag_Ptr is function To_Tag_Ptr is
new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
function To_Type_Specific_Data_Ptr is function To_Type_Specific_Data_Ptr is
new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
------------------------------------------------
-- Unchecked Conversions for other components --
------------------------------------------------
type Acc_Size
is access function (A : System.Address) return Long_Long_Integer;
function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
-- The profile of the implicitly defined _size primitive
------------------------------- -------------------------------
-- Inline_Always Subprograms -- -- Inline_Always Subprograms --
------------------------------- -------------------------------
...@@ -733,7 +720,7 @@ package body Ada.Tags is ...@@ -733,7 +720,7 @@ package body Ada.Tags is
begin begin
Len := 1; Len := 1;
while Str (Len) /= ASCII.Nul loop while Str (Len) /= ASCII.NUL loop
Len := Len + 1; Len := Len + 1;
end loop; end loop;
...@@ -778,35 +765,23 @@ package body Ada.Tags is ...@@ -778,35 +765,23 @@ package body Ada.Tags is
-- The tag of the parent is always in the first slot of the table of -- The tag of the parent is always in the first slot of the table of
-- ancestor tags. -- ancestor tags.
Size_Slot : constant Positive := 1;
-- The pointer to the _size primitive is always in the first slot of
-- the dispatch table.
TSD_Ptr : constant Addr_Ptr := TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr := TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all); To_Type_Specific_Data_Ptr (TSD_Ptr.all);
-- Pointer to the TSD -- Pointer to the TSD
Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot);
Parent_Predef_Prims_Ptr : constant Addr_Ptr := Parent_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Parent_Tag) To_Addr_Ptr (To_Address (Parent_Tag)
- DT_Predef_Prims_Offset); - DT_Typeinfo_Ptr_Size);
Parent_Predef_Prims : constant Predef_Prims_Table_Ptr := Parent_TSD : constant Type_Specific_Data_Ptr :=
To_Predef_Prims_Table_Ptr To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
(Parent_Predef_Prims_Ptr.all);
-- The tag of the parent type through the dispatch table and its
-- Predef_Prims field.
F : constant Acc_Size :=
To_Acc_Size (Parent_Predef_Prims (Size_Slot));
-- Access to the _size primitive of the parent
begin begin
-- Here we compute the size of the _parent field of the object -- Here we compute the size of the _parent field of the object
return SSE.Storage_Count (F.all (Obj)); return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
end Parent_Size; end Parent_Size;
---------------- ----------------
...@@ -837,6 +812,56 @@ package body Ada.Tags is ...@@ -837,6 +812,56 @@ package body Ada.Tags is
end if; end if;
end Parent_Tag; end Parent_Tag;
-------------------------------
-- Register_Interface_Offset --
-------------------------------
procedure Register_Interface_Offset
(This : System.Address;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr)
is
Prim_DT : Dispatch_Table_Ptr;
Iface_Table : Interface_Data_Ptr;
begin
-- "This" points to the primary DT and we must save Offset_Value in
-- the Offset_To_Top field of the corresponding dispatch table.
Prim_DT := DT (To_Tag_Ptr (This).all);
Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
-- Save Offset_Value in the table of interfaces of the primary DT.
-- This data will be used by the subprogram "Displace" to give support
-- to backward abstract interface type conversions.
-- Register the offset in the table of interfaces
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
if Is_Static or else Offset_Value = 0 then
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
Offset_Value;
else
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
Offset_Func;
end if;
return;
end if;
end loop;
end if;
-- If we arrive here there is some error in the run-time data structure
raise Program_Error;
end Register_Interface_Offset;
------------------ ------------------
-- Register_Tag -- -- Register_Tag --
------------------ ------------------
...@@ -892,68 +917,26 @@ package body Ada.Tags is ...@@ -892,68 +917,26 @@ package body Ada.Tags is
-- Set_Offset_To_Top -- -- Set_Offset_To_Top --
----------------------- -----------------------
procedure Set_Offset_To_Top procedure Set_Dynamic_Offset_To_Top
(This : System.Address; (This : System.Address;
Interface_T : Tag; Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset; Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr) Offset_Func : Offset_To_Top_Function_Ptr)
is is
Prim_DT : Dispatch_Table_Ptr; Sec_Base : System.Address;
Sec_Base : System.Address; Sec_DT : Dispatch_Table_Ptr;
Sec_DT : Dispatch_Table_Ptr;
Iface_Table : Interface_Data_Ptr;
begin begin
-- Save the offset to top field in the secondary dispatch table -- Save the offset to top field in the secondary dispatch table
if Offset_Value /= 0 then if Offset_Value /= 0 then
Sec_Base := This + Offset_Value; Sec_Base := This + Offset_Value;
Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
if Is_Static then
Sec_DT.Offset_To_Top := Offset_Value;
else
Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
end if;
end if; end if;
-- "This" points to the primary DT and we must save Offset_Value in Register_Interface_Offset
-- the Offset_To_Top field of the corresponding secondary dispatch (This, Interface_T, False, Offset_Value, Offset_Func);
-- table. end Set_Dynamic_Offset_To_Top;
Prim_DT := DT (To_Tag_Ptr (This).all);
Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
-- Save Offset_Value in the table of interfaces of the primary DT.
-- This data will be used by the subprogram "Displace" to give support
-- to backward abstract interface type conversions.
-- Register the offset in the table of interfaces
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top :=
Is_Static;
if Is_Static then
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value
:= Offset_Value;
else
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func
:= Offset_Func;
end if;
return;
end if;
end loop;
end if;
-- If we arrive here there is some error in the run-time data structure
raise Program_Error;
end Set_Offset_To_Top;
---------------------- ----------------------
-- Set_Prim_Op_Kind -- -- Set_Prim_Op_Kind --
......
gcc/ada/a-tags.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -222,7 +222,8 @@ private ...@@ -222,7 +222,8 @@ private
-- type. This construct is used in the handling of dispatching triggers -- type. This construct is used in the handling of dispatching triggers
-- in select statements. -- in select statements.
type Address_Array is array (Positive range <>) of System.Address; type Prim_Ptr is access procedure;
type Address_Array is array (Positive range <>) of Prim_Ptr;
subtype Dispatch_Table is Address_Array (1 .. 1); subtype Dispatch_Table is Address_Array (1 .. 1);
-- Used by GDB to identify the _tags and traverse the run-time structure -- Used by GDB to identify the _tags and traverse the run-time structure
...@@ -242,8 +243,14 @@ private ...@@ -242,8 +243,14 @@ private
type Tag_Ptr is access all Tag; type Tag_Ptr is access all Tag;
pragma No_Strict_Aliasing (Tag_Ptr); pragma No_Strict_Aliasing (Tag_Ptr);
type Offset_To_Top_Ptr is access all SSE.Storage_Offset;
pragma No_Strict_Aliasing (Offset_To_Top_Ptr);
type Tag_Table is array (Natural range <>) of Tag; type Tag_Table is array (Natural range <>) of Tag;
type Size_Ptr is
access function (A : System.Address) return Long_Long_Integer;
type Type_Specific_Data (Idepth : Natural) is record type Type_Specific_Data (Idepth : Natural) is record
-- The discriminant Idepth is the Inheritance Depth Level: Used to -- The discriminant Idepth is the Inheritance Depth Level: Used to
-- implement the membership test associated with single inheritance of -- implement the membership test associated with single inheritance of
...@@ -279,6 +286,12 @@ private ...@@ -279,6 +286,12 @@ private
-- Controller Offset: Used to give support to tagged controlled objects -- Controller Offset: Used to give support to tagged controlled objects
-- (see Get_Deep_Controller at s-finimp) -- (see Get_Deep_Controller at s-finimp)
Size_Func : Size_Ptr;
-- Pointer to the subprogram computing the _size of the object. Used by
-- the run-time whenever a call to the 'size primitive is required. We
-- cannot assume that the contents of dispatch tables are addresses
-- because in some architectures the ABI allows descriptors.
Interfaces_Table : Interface_Data_Ptr; Interfaces_Table : Interface_Data_Ptr;
-- Pointer to the table of interface tags. It is used to implement the -- Pointer to the table of interface tags. It is used to implement the
-- membership test associated with interfaces and also for backward -- membership test associated with interfaces and also for backward
...@@ -370,6 +383,10 @@ private ...@@ -370,6 +383,10 @@ private
use type System.Storage_Elements.Storage_Offset; use type System.Storage_Elements.Storage_Offset;
DT_Offset_To_Top_Offset : constant SSE.Storage_Count :=
DT_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size;
DT_Predef_Prims_Offset : constant SSE.Storage_Count := DT_Predef_Prims_Offset : constant SSE.Storage_Count :=
DT_Typeinfo_Ptr_Size DT_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size + DT_Offset_To_Top_Size
...@@ -474,28 +491,44 @@ private ...@@ -474,28 +491,44 @@ private
pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
-- This procedure is used in s-finimp and is thus exported manually -- This procedure is used in s-finimp and is thus exported manually
procedure Register_Interface_Offset
(This : System.Address;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr);
-- Register in the table of interfaces of the tagged type associated with
-- "This" object the offset of the record component associated with the
-- progenitor Interface_T (that is, the distance from "This" to the object
-- component containing the tag of the secondary dispatch table). In case
-- of constant offset, Is_Static is true and Offset_Value has such value.
-- In case of variable offset, Is_Static is false and Offset_Func is an
-- access to function that must be called to evaluate the offset.
procedure Register_Tag (T : Tag); procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the -- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag -- sake of Internal_Tag
procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); procedure Set_Dynamic_Offset_To_Top
-- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
-- TSD table indexed by Position.
procedure Set_Offset_To_Top
(This : System.Address; (This : System.Address;
Interface_T : Tag; Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset; Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr); Offset_Func : Offset_To_Top_Function_Ptr);
-- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of -- Ada 2005 (AI-251): The compiler generates calls to this routine only
-- the dispatch table. In primary dispatch tables the value of "This" is -- when initializing the Offset_To_Top field of dispatch tables associated
-- not required (and the compiler passes always the Null_Address value) and -- with tagged type whose parent has variable size components. "This" is
-- the Offset_Value is always cero; in secondary dispatch tables "This" -- the object whose dispatch table is being initialized. Interface_T is the
-- points to the object, Interface_T is the interface for which the -- interface for which the secondary dispatch table is being initialized,
-- secondary dispatch table is being initialized, and Offset_Value is the -- and Offset_Value is the distance from "This" to the object component
-- distance from "This" to the object component containing the tag of the -- containing the tag of the secondary dispatch table (a zero value means
-- secondary dispatch table. -- that this interface shares the primary dispatch table). Offset_Func
-- references a function that must be called to evaluate the offset at
-- runtime. This routine also takes care of registering these values in
-- the table of interfaces of the type.
procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
-- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
-- TSD table indexed by Position.
procedure Set_Prim_Op_Kind procedure Set_Prim_Op_Kind
(T : Tag; (T : Tag;
...@@ -532,5 +565,7 @@ private ...@@ -532,5 +565,7 @@ private
type Addr_Ptr is access System.Address; type Addr_Ptr is access System.Address;
pragma No_Strict_Aliasing (Addr_Ptr); pragma No_Strict_Aliasing (Addr_Ptr);
-- Why is this needed ??? -- This type is used by the frontend to generate the code that handles
-- dispatch table slots of types declared at the local level.
end Ada.Tags; end Ada.Tags;
gcc/ada/checks.adb
...@@ -450,6 +450,17 @@ package body Checks is ...@@ -450,6 +450,17 @@ package body Checks is
return; return;
end if; end if;
-- No check if accessing the Offset_To_Top component of a dispatch
-- table. They are safe by construction.
if Present (Etype (P))
and then RTU_Loaded (Ada_Tags)
and then RTE_Available (RE_Offset_To_Top_Ptr)
and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
then
return;
end if;
-- Otherwise go ahead and install the check -- Otherwise go ahead and install the check
Install_Null_Excluding_Check (P); Install_Null_Excluding_Check (P);
...@@ -1239,12 +1250,23 @@ package body Checks is ...@@ -1239,12 +1250,23 @@ package body Checks is
return; return;
end if; end if;
exit when -- If the expressions for the discriminants are identical
not Is_OK_Static_Expression (ItemS) -- and it is side-effect free (for now just an entity),
or else -- this may be a shared constraint, e.g. from a subtype
not Is_OK_Static_Expression (ItemT); -- without a constraint introduced as a generic actual.
-- Examine other discriminants if any.
if ItemS = ItemT
and then Is_Entity_Name (ItemS)
then
null;
elsif not Is_OK_Static_Expression (ItemS)
or else not Is_OK_Static_Expression (ItemT)
then
exit;
if Expr_Value (ItemS) /= Expr_Value (ItemT) then elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then
if Do_Access then -- needs run-time check. if Do_Access then -- needs run-time check.
exit; exit;
else else
...@@ -2723,10 +2745,13 @@ package body Checks is ...@@ -2723,10 +2745,13 @@ package body Checks is
end if; end if;
end if; end if;
-- Check that null-excluding objects are always initialized -- Check that null-excluding objects are always initialized, except for
-- deferred constants, for which the expression will appear in the full
-- declaration.
if K = N_Object_Declaration if K = N_Object_Declaration
and then No (Expression (N)) and then No (Expression (N))
and then not Constant_Present (N)
and then not No_Initialization (N) and then not No_Initialization (N)
then then
-- Add an expression that assigns null. This node is needed by -- Add an expression that assigns null. This node is needed by
...@@ -2742,9 +2767,9 @@ package body Checks is ...@@ -2742,9 +2767,9 @@ package body Checks is
Reason => CE_Null_Not_Allowed); Reason => CE_Null_Not_Allowed);
end if; end if;
-- Check that a null-excluding component, formal or object is not -- Check that a null-excluding component, formal or object is not being
-- being assigned a null value. Otherwise generate a warning message -- assigned a null value. Otherwise generate a warning message and
-- and replace Expression (N) by a N_Constraint_Error node. -- replace Expression (N) by an N_Contraint_Error node.
if K /= N_Function_Specification then if K /= N_Function_Specification then
Expr := Expression (N); Expr := Expression (N);
...@@ -3368,14 +3393,14 @@ package body Checks is ...@@ -3368,14 +3393,14 @@ package body Checks is
-- Nothing to do if the range of the result is known OK. We skip this -- Nothing to do if the range of the result is known OK. We skip this
-- for conversions, since the caller already did the check, and in any -- for conversions, since the caller already did the check, and in any
-- case the condition for deleting the check for a type conversion is -- case the condition for deleting the check for a type conversion is
-- different in any case. -- different.
if Nkind (N) /= N_Type_Conversion then if Nkind (N) /= N_Type_Conversion then
Determine_Range (N, OK, Lo, Hi); Determine_Range (N, OK, Lo, Hi);
-- Note in the test below that we assume that if a bound of the -- Note in the test below that we assume that the range is not OK
-- range is equal to that of the type. That's not quite accurate -- if a bound of the range is equal to that of the type. That's not
-- but we do this for the following reasons: -- quite accurate but we do this for the following reasons:
-- a) The way that Determine_Range works, it will typically report -- a) The way that Determine_Range works, it will typically report
-- the bounds of the value as being equal to the bounds of the -- the bounds of the value as being equal to the bounds of the
...@@ -3385,7 +3410,7 @@ package body Checks is ...@@ -3385,7 +3410,7 @@ package body Checks is
-- b) It is very unusual to have a situation in which this would -- b) It is very unusual to have a situation in which this would
-- generate an unnecessary overflow check (an example would be -- generate an unnecessary overflow check (an example would be
-- a subtype with a range 0 .. Integer'Last - 1 to which the -- a subtype with a range 0 .. Integer'Last - 1 to which the
-- literal value one is added. -- literal value one is added).
-- c) The alternative is a lot of special casing in this routine -- c) The alternative is a lot of special casing in this routine
-- which would partially duplicate Determine_Range processing. -- which would partially duplicate Determine_Range processing.
...@@ -4121,12 +4146,7 @@ package body Checks is ...@@ -4121,12 +4146,7 @@ package body Checks is
-- appropriate one for our purposes. -- appropriate one for our purposes.
if (Ekind (Ent) = E_Variable if (Ekind (Ent) = E_Variable
or else or else Is_Constant_Object (Ent))
Ekind (Ent) = E_Constant
or else
Ekind (Ent) = E_Loop_Parameter
or else
Ekind (Ent) = E_In_Parameter)
and then not Is_Library_Level_Entity (Ent) and then not Is_Library_Level_Entity (Ent)
then then
Entry_OK := True; Entry_OK := True;
...@@ -4371,7 +4391,8 @@ package body Checks is ...@@ -4371,7 +4391,8 @@ package body Checks is
Duplicate_Subexpr_Move_Checks (Sub)), Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd => Right_Opnd =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr_Move_Checks (A), Prefix =>
Duplicate_Subexpr_Move_Checks (A, Name_Req => True),
Attribute_Name => Name_Range, Attribute_Name => Name_Range,
Expressions => Num)), Expressions => Num)),
Reason => CE_Index_Check_Failed)); Reason => CE_Index_Check_Failed));
......
gcc/ada/checks.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -211,7 +211,7 @@ package Checks is ...@@ -211,7 +211,7 @@ package Checks is
-- by the back end, but many are done by the front end. -- by the back end, but many are done by the front end.
-- Overflow checks are similarly controlled by the Do_Overflow_Check flag. -- Overflow checks are similarly controlled by the Do_Overflow_Check flag.
-- The difference here is that if Backend_Overflow_Checks is is -- The difference here is that if back end overflow checks are inactive
-- (Backend_Overflow_Checks_On_Target set False), then the actual overflow -- (Backend_Overflow_Checks_On_Target set False), then the actual overflow
-- checks are generated by the front end, but if back end overflow checks -- checks are generated by the front end, but if back end overflow checks
-- are active (Backend_Overflow_Checks_On_Target set True), then the back -- are active (Backend_Overflow_Checks_On_Target set True), then the back
......
gcc/ada/exp_atag.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -26,9 +26,11 @@ ...@@ -26,9 +26,11 @@
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
with Rtsfind; use Rtsfind; with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Stand; use Stand; with Stand; use Stand;
with Snames; use Snames; with Snames; use Snames;
...@@ -57,15 +59,6 @@ package body Exp_Atag is ...@@ -57,15 +59,6 @@ package body Exp_Atag is
-- Generate: To_Type_Specific_Data_Ptr -- Generate: To_Type_Specific_Data_Ptr
-- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all); -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
function Build_Predef_Prims
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id;
-- Build code that retrieves the address of the dispatch table containing
-- the predefined Ada primitives:
--
-- Generate: To_Predef_Prims_Table_Ptr
-- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
------------------------------------------------ ------------------------------------------------
-- Build_Common_Dispatching_Select_Statements -- -- Build_Common_Dispatching_Select_Statements --
------------------------------------------------ ------------------------------------------------
...@@ -239,10 +232,33 @@ package body Exp_Atag is ...@@ -239,10 +232,33 @@ package body Exp_Atag is
Position : Uint) return Node_Id Position : Uint) return Node_Id
is is
begin begin
-- Build code that retrieves the address of the dispatch table
-- containing the predefined Ada primitives:
--
-- Generate:
-- To_Predef_Prims_Table_Ptr
-- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
return return
Make_Indexed_Component (Loc, Make_Indexed_Component (Loc,
Prefix => Prefix =>
Build_Predef_Prims (Loc, Tag_Node), Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
Loc)))))),
Expressions => Expressions =>
New_List (Make_Integer_Literal (Loc, Position))); New_List (Make_Integer_Literal (Loc, Position)));
end Build_Get_Predefined_Prim_Op_Address; end Build_Get_Predefined_Prim_Op_Address;
...@@ -397,35 +413,37 @@ package body Exp_Atag is ...@@ -397,35 +413,37 @@ package body Exp_Atag is
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
end Build_Inherit_Predefined_Prims; end Build_Inherit_Predefined_Prims;
------------------------ -------------------------
-- Build_Predef_Prims -- -- Build_Offset_To_Top --
------------------------ -------------------------
function Build_Predef_Prims function Build_Offset_To_Top
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id This_Node : Node_Id) return Node_Id
is is
Tag_Node : Node_Id;
begin begin
return Tag_Node :=
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), Make_Explicit_Dereference (Loc,
Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
Unchecked_Convert_To (RTE (RE_Addr_Ptr),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix =>
New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name =>
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List ( return
Unchecked_Convert_To (RTE (RE_Address), Tag_Node), Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_DT_Predef_Prims_Offset), Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
Loc)))))); Make_Function_Call (Loc,
end Build_Predef_Prims; Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix => New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name => Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
Loc)))));
end Build_Offset_To_Top;
------------------------------------------ ------------------------------------------
-- Build_Set_Predefined_Prim_Op_Address -- -- Build_Set_Predefined_Prim_Op_Address --
...@@ -471,6 +489,60 @@ package body Exp_Atag is ...@@ -471,6 +489,60 @@ package body Exp_Atag is
Expression => Address_Node); Expression => Address_Node);
end Build_Set_Prim_Op_Address; end Build_Set_Prim_Op_Address;
-----------------------------
-- Build_Set_Size_Function --
-----------------------------
function Build_Set_Size_Function
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Size_Func : Entity_Id) return Node_Id is
begin
pragma Assert (Chars (Size_Func) = Name_uSize
and then RTE_Record_Component_Available (RE_Size_Func));
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Size_Func), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Size_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Size_Func, Loc),
Attribute_Name => Name_Unrestricted_Access)));
end Build_Set_Size_Function;
------------------------------------
-- Build_Set_Static_Offset_To_Top --
------------------------------------
function Build_Set_Static_Offset_To_Top
(Loc : Source_Ptr;
Iface_Tag : Node_Id;
Offset_Value : Node_Id) return Node_Id is
begin
return
Make_Assignment_Statement (Loc,
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
Make_Function_Call (Loc,
Name =>
Make_Expanded_Name (Loc,
Chars => Name_Op_Subtract,
Prefix => New_Reference_To
(RTU_Entity (System_Storage_Elements), Loc),
Selector_Name => Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
Loc))))),
Offset_Value);
end Build_Set_Static_Offset_To_Top;
--------------- ---------------
-- Build_TSD -- -- Build_TSD --
--------------- ---------------
......
gcc/ada/exp_atag.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -117,6 +117,19 @@ package Exp_Atag is ...@@ -117,6 +117,19 @@ package Exp_Atag is
-- New_Tag.Prims_Ptr (1 .. Num_Prims) := -- New_Tag.Prims_Ptr (1 .. Num_Prims) :=
-- Old_Tag.Prims_Ptr (1 .. Num_Prims); -- Old_Tag.Prims_Ptr (1 .. Num_Prims);
function Build_Offset_To_Top
(Loc : Source_Ptr;
This_Node : Node_Id) return Node_Id;
-- Build code that references the Offset_To_Top component of the primary
-- or secondary dispatch table associated with This_Node. This subprogram
-- provides a subset of the functionality provided by the function
-- Offset_To_Top of package Ada.Tags, and is only called by the frontend
-- when such routine is not available in a configurable runtime.
--
-- Generates:
-- Offset_To_Top_Ptr
-- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset)
function Build_Set_Predefined_Prim_Op_Address function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr; (Loc : Source_Ptr;
Tag_Node : Node_Id; Tag_Node : Node_Id;
...@@ -145,4 +158,23 @@ package Exp_Atag is ...@@ -145,4 +158,23 @@ package Exp_Atag is
-- --
-- Generates: Tag.D (Position) := Value -- Generates: Tag.D (Position) := Value
function Build_Set_Size_Function
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Size_Func : Entity_Id) return Node_Id;
-- Build code that saves in the TSD the address of the function
-- calculating _size of the object.
function Build_Set_Static_Offset_To_Top
(Loc : Source_Ptr;
Iface_Tag : Node_Id;
Offset_Value : Node_Id) return Node_Id;
-- Build code that initialize the Offset_To_Top component of the
-- secondary dispatch table referenced by Iface_Tag.
--
-- Generates:
-- Offset_To_Top_Ptr
-- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all
-- := Offset_Value
end Exp_Atag; end Exp_Atag;
gcc/ada/exp_ch13.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -145,21 +145,29 @@ package body Exp_Ch13 is ...@@ -145,21 +145,29 @@ package body Exp_Ch13 is
-- For Storage_Size for an access type, create a variable to hold -- For Storage_Size for an access type, create a variable to hold
-- the value of the specified size with name typeV and expand an -- the value of the specified size with name typeV and expand an
-- assignment statement to initialze this value. -- assignment statement to initialize this value.
elsif Is_Access_Type (Ent) then elsif Is_Access_Type (Ent) then
V := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Ent), 'V'));
Insert_Action (N, -- We don't need the variable for a storage size of zero
Make_Object_Declaration (Loc,
Defining_Identifier => V, if not No_Pool_Assigned (Ent) then
Object_Definition => V :=
New_Reference_To (RTE (RE_Storage_Offset), Loc), Make_Defining_Identifier (Loc,
Expression => Chars => New_External_Name (Chars (Ent), 'V'));
Convert_To (RTE (RE_Storage_Offset), Expression (N))));
Set_Storage_Size_Variable (Ent, Entity_Id (V)); -- Insert the declaration of the object
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => V,
Object_Definition =>
New_Reference_To (RTE (RE_Storage_Offset), Loc),
Expression =>
Convert_To (RTE (RE_Storage_Offset), Expression (N))));
Set_Storage_Size_Variable (Ent, Entity_Id (V));
end if;
end if; end if;
-- Other attributes require no expansion -- Other attributes require no expansion
...@@ -207,6 +215,15 @@ package body Exp_Ch13 is ...@@ -207,6 +215,15 @@ package body Exp_Ch13 is
return; return;
end if; end if;
-- Remember that we are processing a freezing entity and its freezing
-- nodes. This flag (non-zero = set) is used to avoid the need of
-- climbing through the tree while processing the freezing actions (ie.
-- to avoid generating spurious warnings or to avoid killing constant
-- indications while processing the code associated with freezing
-- actions). We use a counter to deal with nesting.
Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
-- If we are freezing entities defined in protected types, they belong -- If we are freezing entities defined in protected types, they belong
-- in the enclosing scope, given that the original type has been -- in the enclosing scope, given that the original type has been
-- expanded away. The same is true for entities in task types, in -- expanded away. The same is true for entities in task types, in
...@@ -224,7 +241,6 @@ package body Exp_Ch13 is ...@@ -224,7 +241,6 @@ package body Exp_Ch13 is
elsif Ekind (E_Scope) = E_Subprogram_Body then elsif Ekind (E_Scope) = E_Subprogram_Body then
E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope)); E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
end if; end if;
S := Current_Scope; S := Current_Scope;
...@@ -339,6 +355,11 @@ package body Exp_Ch13 is ...@@ -339,6 +355,11 @@ package body Exp_Ch13 is
elsif In_Outer_Scope then elsif In_Outer_Scope then
Pop_Scope; Pop_Scope;
end if; end if;
-- Restore previous value of the nesting-level counter that records
-- whether we are inside a (possibly nested) call to this procedure.
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
end Expand_N_Freeze_Entity; end Expand_N_Freeze_Entity;
------------------------------------------- -------------------------------------------
......
gcc/ada/exp_ch3.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -133,16 +133,18 @@ package Exp_Ch3 is ...@@ -133,16 +133,18 @@ package Exp_Ch3 is
function Get_Simple_Init_Val function Get_Simple_Init_Val
(T : Entity_Id; (T : Entity_Id;
Loc : Source_Ptr; N : Node_Id;
Size : Uint := No_Uint) return Node_Id; Size : Uint := No_Uint) return Node_Id;
-- For a type which Needs_Simple_Initialization (see above), prepares the -- For a type which Needs_Simple_Initialization (see above), prepares the
-- tree for an expression representing the required initial value. Loc is -- tree for an expression representing the required initial value. N is a
-- the source location used in constructing this tree which is returned as -- node whose source location used in constructing this tree which is
-- the result of the call. The Size parameter indicates the target size of -- returned as the result of the call. The Size parameter indicates the
-- the object if it is known (indicated by a value that is not No_Uint and -- target size of the object if it is known (indicated by a value that is
-- is greater than zero). If Size is not given (Size set to No_Uint, or -- not No_Uint and is greater than zero). If Size is not given (Size set to
-- non-positive), then the Esize of T is used as an estimate of the Size. -- No_Uint, or non-positive), then the Esize of T is used as an estimate of
-- The object size is needed to prepare a known invalid value for use by -- the Size. The object size is needed to prepare a known invalid value for
-- Normalize_Scalars. -- use by Normalize_Scalars. A call to this routine where T is a scalar
-- type is only valid if we are in Normalize_Scalars or Initialize_Scalars
-- mode, or if N is the node for a 'Invalid_Value attribute node.
end Exp_Ch3; end Exp_Ch3;
gcc/ada/rtsfind.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -283,6 +283,9 @@ package body Rtsfind is ...@@ -283,6 +283,9 @@ package body Rtsfind is
if U_Id in Ada_Calendar_Child then if U_Id in Ada_Calendar_Child then
Name_Buffer (13) := '.'; Name_Buffer (13) := '.';
elsif U_Id in Ada_Dispatching_Child then
Name_Buffer (16) := '.';
elsif U_Id in Ada_Finalization_Child then elsif U_Id in Ada_Finalization_Child then
Name_Buffer (17) := '.'; Name_Buffer (17) := '.';
...@@ -311,6 +314,10 @@ package body Rtsfind is ...@@ -311,6 +314,10 @@ package body Rtsfind is
elsif U_Id in System_Child then elsif U_Id in System_Child then
Name_Buffer (7) := '.'; Name_Buffer (7) := '.';
if U_Id in System_Strings_Child then
Name_Buffer (15) := '.';
end if;
if U_Id in System_Tasking_Child then if U_Id in System_Tasking_Child then
Name_Buffer (15) := '.'; Name_Buffer (15) := '.';
end if; end if;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment