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 938 additions and 455 deletions
gcc/ada/a-tags.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -105,25 +105,12 @@ package body Ada.Tags is
function To_Object_Specific_Data_Ptr is
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
new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
function To_Type_Specific_Data_Ptr is
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 --
-------------------------------
......@@ -733,7 +720,7 @@ package body Ada.Tags is
begin
Len := 1;
while Str (Len) /= ASCII.Nul loop
while Str (Len) /= ASCII.NUL loop
Len := Len + 1;
end loop;
......@@ -778,35 +765,23 @@ package body Ada.Tags is
-- The tag of the parent is always in the first slot of the table of
-- 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 :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
-- Pointer to the TSD
Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot);
Parent_Predef_Prims_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Parent_Tag)
- DT_Predef_Prims_Offset);
Parent_Predef_Prims : constant Predef_Prims_Table_Ptr :=
To_Predef_Prims_Table_Ptr
(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
Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot);
Parent_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Parent_Tag)
- DT_Typeinfo_Ptr_Size);
Parent_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
begin
-- 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;
----------------
......@@ -837,6 +812,56 @@ package body Ada.Tags is
end if;
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 --
------------------
......@@ -892,68 +917,26 @@ package body Ada.Tags is
-- Set_Offset_To_Top --
-----------------------
procedure Set_Offset_To_Top
procedure Set_Dynamic_Offset_To_Top
(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;
Sec_Base : System.Address;
Sec_DT : Dispatch_Table_Ptr;
Iface_Table : Interface_Data_Ptr;
Sec_Base : System.Address;
Sec_DT : Dispatch_Table_Ptr;
begin
-- Save the offset to top field in the secondary dispatch table
if Offset_Value /= 0 then
Sec_Base := This + Offset_Value;
Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
if Is_Static then
Sec_DT.Offset_To_Top := Offset_Value;
else
Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
end if;
Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
end if;
-- "This" points to the primary DT and we must save Offset_Value in
-- the Offset_To_Top field of the corresponding secondary 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
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;
Register_Interface_Offset
(This, Interface_T, False, Offset_Value, Offset_Func);
end Set_Dynamic_Offset_To_Top;
----------------------
-- Set_Prim_Op_Kind --
......
gcc/ada/a-tags.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- GNAT. The copyright notice above, and the license provisions that follow --
......@@ -222,7 +222,8 @@ private
-- type. This construct is used in the handling of dispatching triggers
-- 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);
-- Used by GDB to identify the _tags and traverse the run-time structure
......@@ -242,8 +243,14 @@ private
type Tag_Ptr is access all Tag;
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 Size_Ptr is
access function (A : System.Address) return Long_Long_Integer;
type Type_Specific_Data (Idepth : Natural) is record
-- The discriminant Idepth is the Inheritance Depth Level: Used to
-- implement the membership test associated with single inheritance of
......@@ -279,6 +286,12 @@ private
-- Controller Offset: Used to give support to tagged controlled objects
-- (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;
-- Pointer to the table of interface tags. It is used to implement the
-- membership test associated with interfaces and also for backward
......@@ -370,6 +383,10 @@ private
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_Typeinfo_Ptr_Size
+ DT_Offset_To_Top_Size
......@@ -474,28 +491,44 @@ private
pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
-- 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);
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
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_Offset_To_Top
procedure Set_Dynamic_Offset_To_Top
(This : System.Address;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr);
-- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
-- the dispatch table. In primary dispatch tables the value of "This" is
-- not required (and the compiler passes always the Null_Address value) and
-- the Offset_Value is always cero; in secondary dispatch tables "This"
-- points to the object, Interface_T is the interface for which the
-- secondary dispatch table is being initialized, and Offset_Value is the
-- distance from "This" to the object component containing the tag of the
-- secondary dispatch table.
-- Ada 2005 (AI-251): The compiler generates calls to this routine only
-- when initializing the Offset_To_Top field of dispatch tables associated
-- with tagged type whose parent has variable size components. "This" is
-- the object whose dispatch table is being initialized. Interface_T is the
-- interface for which the secondary dispatch table is being initialized,
-- and Offset_Value is the distance from "This" to the object component
-- containing the tag of the secondary dispatch table (a zero value means
-- 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
(T : Tag;
......@@ -532,5 +565,7 @@ private
type Addr_Ptr is access System.Address;
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;
gcc/ada/checks.adb
......@@ -450,6 +450,17 @@ package body Checks is
return;
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
Install_Null_Excluding_Check (P);
......@@ -1239,12 +1250,23 @@ package body Checks is
return;
end if;
exit when
not Is_OK_Static_Expression (ItemS)
or else
not Is_OK_Static_Expression (ItemT);
-- If the expressions for the discriminants are identical
-- and it is side-effect free (for now just an entity),
-- this may be a shared constraint, e.g. from a subtype
-- 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.
exit;
else
......@@ -2723,10 +2745,13 @@ package body Checks is
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
and then No (Expression (N))
and then not Constant_Present (N)
and then not No_Initialization (N)
then
-- Add an expression that assigns null. This node is needed by
......@@ -2742,9 +2767,9 @@ package body Checks is
Reason => CE_Null_Not_Allowed);
end if;
-- Check that a null-excluding component, formal or object is not
-- being assigned a null value. Otherwise generate a warning message
-- and replace Expression (N) by a N_Constraint_Error node.
-- Check that a null-excluding component, formal or object is not being
-- assigned a null value. Otherwise generate a warning message and
-- replace Expression (N) by an N_Contraint_Error node.
if K /= N_Function_Specification then
Expr := Expression (N);
......@@ -3368,14 +3393,14 @@ package body Checks is
-- 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
-- case the condition for deleting the check for a type conversion is
-- different in any case.
-- different.
if Nkind (N) /= N_Type_Conversion then
Determine_Range (N, OK, Lo, Hi);
-- Note in the test below that we assume that if a bound of the
-- range is equal to that of the type. That's not quite accurate
-- but we do this for the following reasons:
-- Note in the test below that we assume that the range is not OK
-- if a bound of the range is equal to that of the type. That's not
-- quite accurate but we do this for the following reasons:
-- a) The way that Determine_Range works, it will typically report
-- the bounds of the value as being equal to the bounds of the
......@@ -3385,7 +3410,7 @@ package body Checks is
-- b) It is very unusual to have a situation in which this would
-- generate an unnecessary overflow check (an example would be
-- 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
-- which would partially duplicate Determine_Range processing.
......@@ -4121,12 +4146,7 @@ package body Checks is
-- appropriate one for our purposes.
if (Ekind (Ent) = E_Variable
or else
Ekind (Ent) = E_Constant
or else
Ekind (Ent) = E_Loop_Parameter
or else
Ekind (Ent) = E_In_Parameter)
or else Is_Constant_Object (Ent))
and then not Is_Library_Level_Entity (Ent)
then
Entry_OK := True;
......@@ -4371,7 +4391,8 @@ package body Checks is
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr_Move_Checks (A),
Prefix =>
Duplicate_Subexpr_Move_Checks (A, Name_Req => True),
Attribute_Name => Name_Range,
Expressions => Num)),
Reason => CE_Index_Check_Failed));
......
gcc/ada/checks.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -211,7 +211,7 @@ package Checks is
-- by the back end, but many are done by the front end.
-- 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
-- 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
......
gcc/ada/exp_atag.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -26,9 +26,11 @@
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem_Util; use Sem_Util;
with Stand; use Stand;
with Snames; use Snames;
......@@ -57,15 +59,6 @@ package body Exp_Atag is
-- Generate: To_Type_Specific_Data_Ptr
-- (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 --
------------------------------------------------
......@@ -239,10 +232,33 @@ package body Exp_Atag is
Position : Uint) return Node_Id
is
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
Make_Indexed_Component (Loc,
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 =>
New_List (Make_Integer_Literal (Loc, Position)));
end Build_Get_Predefined_Prim_Op_Address;
......@@ -397,35 +413,37 @@ package body Exp_Atag is
New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
end Build_Inherit_Predefined_Prims;
------------------------
-- Build_Predef_Prims --
------------------------
-------------------------
-- Build_Offset_To_Top --
-------------------------
function Build_Predef_Prims
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id
function Build_Offset_To_Top
(Loc : Source_Ptr;
This_Node : Node_Id) return Node_Id
is
Tag_Node : Node_Id;
begin
return
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)),
Tag_Node :=
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
Loc))))));
end Build_Predef_Prims;
return
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), Tag_Node),
New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
Loc)))));
end Build_Offset_To_Top;
------------------------------------------
-- Build_Set_Predefined_Prim_Op_Address --
......@@ -471,6 +489,60 @@ package body Exp_Atag is
Expression => Address_Node);
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 --
---------------
......
gcc/ada/exp_atag.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -117,6 +117,19 @@ package Exp_Atag is
-- New_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
(Loc : Source_Ptr;
Tag_Node : Node_Id;
......@@ -145,4 +158,23 @@ package Exp_Atag is
--
-- 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;
gcc/ada/exp_ch13.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -145,21 +145,29 @@ package body Exp_Ch13 is
-- For Storage_Size for an access type, create a variable to hold
-- 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
V := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Ent), 'V'));
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))));
-- We don't need the variable for a storage size of zero
if not No_Pool_Assigned (Ent) then
V :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Ent), 'V'));
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;
-- Other attributes require no expansion
......@@ -207,6 +215,15 @@ package body Exp_Ch13 is
return;
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
-- in the enclosing scope, given that the original type has been
-- expanded away. The same is true for entities in task types, in
......@@ -224,7 +241,6 @@ package body Exp_Ch13 is
elsif Ekind (E_Scope) = E_Subprogram_Body then
E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
end if;
S := Current_Scope;
......@@ -339,6 +355,11 @@ package body Exp_Ch13 is
elsif In_Outer_Scope then
Pop_Scope;
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;
-------------------------------------------
......
gcc/ada/exp_ch3.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -570,7 +570,7 @@ package body Exp_Ch3 is
Name => Comp,
Expression =>
Get_Simple_Init_Val
(Comp_Type, Loc, Component_Size (A_Type))));
(Comp_Type, Nod, Component_Size (A_Type))));
else
Clean_Task_Names (Comp_Type, Proc_Id);
......@@ -680,7 +680,18 @@ package body Exp_Ch3 is
and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
then
Proc_Id :=
Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type));
Make_Defining_Identifier (Loc,
Chars => Make_Init_Proc_Name (A_Type));
-- If No_Default_Initialization restriction is active, then we don't
-- want to build an init_proc, but we need to mark that an init_proc
-- would be needed if this restriction was not active (so that we can
-- detect attempts to call it), so set a dummy init_proc in place.
if Restriction_Active (No_Default_Initialization) then
Set_Init_Proc (A_Type, Proc_Id);
return;
end if;
Body_Stmts := Init_One_Dimension (1);
......@@ -1018,15 +1029,17 @@ package body Exp_Ch3 is
begin
-- Build the discriminant checking function for each variant, label
-- all components of that variant with the function's name.
-- We only Generate a discriminant-checking function only if the
-- variant is not empty, to prevent the creation of dead code.
Discr_Name := Entity (Name (Variant_Part_Node));
Variant := First_Non_Pragma (Variants (Variant_Part_Node));
while Present (Variant) loop
Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
Component_List_Node := Component_List (Variant);
if not Null_Present (Component_List_Node) then
Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
Decl :=
First_Non_Pragma (Component_Items (Component_List_Node));
......@@ -2172,10 +2185,6 @@ package body Exp_Ch3 is
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_Init_Proc_Name (Rec_Type));
Set_Ekind (Proc_Id, E_Procedure);
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
......@@ -2567,7 +2576,7 @@ package body Exp_Ch3 is
elsif Component_Needs_Simple_Initialization (Typ) then
Stmts :=
Build_Assignment
(Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)));
(Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
-- Nothing needed for this case
......@@ -2635,7 +2644,7 @@ package body Exp_Ch3 is
elsif Component_Needs_Simple_Initialization (Typ) then
Append_List_To (Statement_List,
Build_Assignment
(Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))));
(Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
end if;
end if;
......@@ -3003,7 +3012,6 @@ package body Exp_Ch3 is
end if;
Id := First_Component (Rec_Id);
while Present (Id) loop
Comp_Decl := Parent (Id);
Typ := Etype (Id);
......@@ -3024,6 +3032,8 @@ package body Exp_Ch3 is
-- Start of processing for Build_Record_Init_Proc
begin
-- Check for value type, which means no initialization required
Rec_Type := Defining_Identifier (N);
if Is_Value_Type (Rec_Type) then
......@@ -3080,6 +3090,20 @@ package body Exp_Ch3 is
elsif Requires_Init_Proc (Rec_Type)
or else Is_Unchecked_Union (Rec_Type)
then
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_Init_Proc_Name (Rec_Type));
-- If No_Default_Initialization restriction is active, then we don't
-- want to build an init_proc, but we need to mark that an init_proc
-- would be needed if this restriction was not active (so that we can
-- detect attempts to call it), so set a dummy init_proc in place.
if Restriction_Active (No_Default_Initialization) then
Set_Init_Proc (Rec_Type, Proc_Id);
return;
end if;
Build_Offset_To_Top_Functions;
Build_Init_Procedure;
Set_Is_Public (Proc_Id, Is_Public (Pe));
......@@ -3121,13 +3145,12 @@ package body Exp_Ch3 is
procedure Collect_Itypes (Comp : Node_Id) is
Ref : Node_Id;
Sub_Aggr : Node_Id;
Typ : Entity_Id;
Typ : constant Entity_Id := Etype (Comp);
begin
if Is_Array_Type (Etype (Comp))
and then Is_Itype (Etype (Comp))
if Is_Array_Type (Typ)
and then Is_Itype (Typ)
then
Typ := Etype (Comp);
Ref := Make_Itype_Reference (Loc);
Set_Itype (Ref, Typ);
Append_Freeze_Action (Rec_Type, Ref);
......@@ -3189,6 +3212,11 @@ package body Exp_Ch3 is
-- Ri1 : Index;
-- begin
-- if Left_Hi < Left_Lo then
-- return;
-- end if;
-- if Rev then
-- Li1 := Left_Hi;
-- Ri1 := Right_Hi;
......@@ -3198,18 +3226,14 @@ package body Exp_Ch3 is
-- end if;
-- loop
-- if Rev then
-- exit when Li1 < Left_Lo;
-- else
-- exit when Li1 > Left_Hi;
-- end if;
-- Target (Li1) := Source (Ri1);
-- if Rev then
-- exit when Li1 = Left_Lo;
-- Li1 := Index'pred (Li1);
-- Ri1 := Index'pred (Ri1);
-- else
-- exit when Li1 = Left_Hi;
-- Li1 := Index'succ (Li1);
-- Ri1 := Index'succ (Ri1);
-- end if;
......@@ -3276,6 +3300,16 @@ package body Exp_Ch3 is
Stats := New_List;
-- Build test for empty slice case
Append_To (Stats,
Make_If_Statement (Loc,
Condition =>
Make_Op_Lt (Loc,
Left_Opnd => New_Occurrence_Of (Left_Hi, Loc),
Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
-- Build initializations for indices
declare
......@@ -3326,7 +3360,7 @@ package body Exp_Ch3 is
Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
End_Label => Empty);
-- Build exit condition
-- Build the exit condition and increment/decrement statements
declare
F_Ass : constant List_Id := New_List;
......@@ -3336,31 +3370,10 @@ package body Exp_Ch3 is
Append_To (F_Ass,
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Gt (Loc,
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
Append_To (B_Ass,
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Lt (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
Prepend_To (Statements (Loops),
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Rev, Loc),
Then_Statements => B_Ass,
Else_Statements => F_Ass));
end;
-- Build the increment/decrement statements
declare
F_Ass : constant List_Id := New_List;
B_Ass : constant List_Id := New_List;
begin
Append_To (F_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
......@@ -3384,6 +3397,13 @@ package body Exp_Ch3 is
New_Occurrence_Of (Rnn, Loc)))));
Append_To (B_Ass,
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Lnn, Loc),
Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
Append_To (B_Ass,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Lnn, Loc),
Expression =>
......@@ -4220,6 +4240,12 @@ package body Exp_Ch3 is
and then not Suppress_Init_Proc (Typ)
then
Check_Restriction (No_Default_Initialization, N);
if Restriction_Active (No_Default_Initialization) then
return;
end if;
-- The call to the initialization procedure does NOT freeze the
-- object being initialized. This is because the call is not a
-- source level call. This works fine, because the only possible
......@@ -4260,8 +4286,9 @@ package body Exp_Ch3 is
and then not Is_Internal (Def_Id)
and then not Has_Init_Expression (N)
then
Check_Restriction (No_Default_Initialization, N);
Set_No_Initialization (N, False);
Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id)));
Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
Analyze_And_Resolve (Expression (N), Typ);
end if;
......@@ -5437,10 +5464,18 @@ package body Exp_Ch3 is
Set_Is_Frozen (Def_Id, False);
-- Do not add the spec of predefined primitives in case of
-- CPP tagged type derivations that have convention CPP.
if Is_CPP_Class (Root_Type (Def_Id))
and then Convention (Def_Id) = Convention_CPP
then
null;
-- Do not add the spec of the predefined primitives if we are
-- compiling under restriction No_Dispatching_Calls
if not Restriction_Active (No_Dispatching_Calls) then
elsif not Restriction_Active (No_Dispatching_Calls) then
Make_Predefined_Primitive_Specs
(Def_Id, Predef_List, Renamed_Eq);
Insert_List_Before_And_Analyze (N, Predef_List);
......@@ -5614,11 +5649,19 @@ package body Exp_Ch3 is
if Is_Tagged_Type (Def_Id)
and then not Is_Interface (Def_Id)
then
-- Do not add the body of predefined primitives in case of
-- CPP tagged type derivations that have convention CPP.
if Is_CPP_Class (Root_Type (Def_Id))
and then Convention (Def_Id) = Convention_CPP
then
null;
-- Do not add the body of the predefined primitives if we are
-- compiling under restriction No_Dispatching_Calls
-- compiling under restriction No_Dispatching_Calls of if we
-- are compiling a CPP tagged type.
if not Restriction_Active (No_Dispatching_Calls) then
elsif not Restriction_Active (No_Dispatching_Calls) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List);
end if;
......@@ -5814,28 +5857,18 @@ package body Exp_Ch3 is
then
declare
Loc : constant Source_Ptr := Sloc (N);
Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
Pool_Object : Entity_Id;
Siz_Exp : Node_Id;
Freeze_Action_Typ : Entity_Id;
begin
if Has_Storage_Size_Clause (Def_Id) then
Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id)));
else
Siz_Exp := Empty;
end if;
-- Case 1
-- Rep Clause "for Def_Id'Storage_Size use 0;"
-- ---> don't use any storage pool
if Has_Storage_Size_Clause (Def_Id)
and then Compile_Time_Known_Value (Siz_Exp)
and then Expr_Value (Siz_Exp) = 0
then
if No_Pool_Assigned (Def_Id) then
null;
-- Case 2
......@@ -6046,9 +6079,10 @@ package body Exp_Ch3 is
function Get_Simple_Init_Val
(T : Entity_Id;
Loc : Source_Ptr;
N : Node_Id;
Size : Uint := No_Uint) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Val : Node_Id;
Result : Node_Id;
Val_RE : RE_Id;
......@@ -6057,6 +6091,10 @@ package body Exp_Ch3 is
-- This is the size to be used for computation of the appropriate
-- initial value for the Normalize_Scalars and Initialize_Scalars case.
IV_Attribute : constant Boolean :=
Nkind (N) = N_Attribute_Reference
and then Attribute_Name (N) = Name_Invalid_Value;
Lo_Bound : Uint;
Hi_Bound : Uint;
-- These are the values computed by the procedure Check_Subtype_Bounds
......@@ -6133,7 +6171,7 @@ package body Exp_Ch3 is
-- an Unchecked_Convert to the private type.
if Is_Private_Type (T) then
Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size);
Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
-- A special case, if the underlying value is null, then qualify it
-- with the underlying type, so that the null is properly typed
......@@ -6160,10 +6198,11 @@ package body Exp_Ch3 is
return Result;
-- For scalars, we must have normalize/initialize scalars case
-- For scalars, we must have normalize/initialize scalars case, or
-- if the node N is an 'Invalid_Value attribute node.
elsif Is_Scalar_Type (T) then
pragma Assert (Init_Or_Norm_Scalars);
pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
-- Compute size of object. If it is given by the caller, we can use
-- it directly, otherwise we use Esize (T) as an estimate. As far as
......@@ -6188,7 +6227,7 @@ package body Exp_Ch3 is
-- Processing for Normalize_Scalars case
if Normalize_Scalars then
if Normalize_Scalars and then not IV_Attribute then
-- If zero is invalid, it is a convenient value to use that is
-- for sure an appropriate invalid value in all situations.
......@@ -6252,7 +6291,7 @@ package body Exp_Ch3 is
end;
end if;
-- Here for Initialize_Scalars case
-- Here for Initialize_Scalars case (or Invalid_Value attribute used)
else
-- For float types, use float values from System.Scalar_Values
......@@ -6347,7 +6386,7 @@ package body Exp_Ch3 is
Make_Others_Choice (Loc)),
Expression =>
Get_Simple_Init_Val
(Component_Type (T), Loc, Esize (Root_Type (T))))));
(Component_Type (T), N, Esize (Root_Type (T))))));
-- Access type is initialized to null
......@@ -6615,14 +6654,6 @@ package body Exp_Ch3 is
New_Reference_To (Iface_Tag, Loc)));
end if;
-- Issue error if Set_Offset_To_Top is not available in a
-- configurable run-time environment.
if not RTE_Available (RE_Set_Offset_To_Top) then
Error_Msg_CRT ("abstract interface types", Typ);
return;
end if;
Comp_Typ := Scope (Tag_Comp);
-- Initialize the entries of the table of interfaces. We generate a
......@@ -6636,17 +6667,26 @@ package body Exp_Ch3 is
pragma Assert
(Present (DT_Offset_To_Top_Func (Tag_Comp)));
-- Issue error if Set_Dynamic_Offset_To_Top is not available in a
-- configurable run-time environment.
if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
Error_Msg_CRT
("variable size record with interface types", Typ);
return;
end if;
-- Generate:
-- Set_Offset_To_Top
-- Set_Dynamic_Offset_To_Top
-- (This => Init,
-- Interface_T => Iface'Tag,
-- Is_Constant => False,
-- Offset_Value => n,
-- Offset_Func => Fn'Address)
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
Name => New_Reference_To
(RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
......@@ -6657,8 +6697,6 @@ package body Exp_Ch3 is
(Node (First_Elmt (Access_Disp_Table (Iface))),
Loc)),
New_Occurrence_Of (Standard_False, Loc),
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
......@@ -6700,42 +6738,63 @@ package body Exp_Ch3 is
-- Normal case: No discriminants in the parent type
else
-- Don't need to set any value if this interface shares
-- the primary dispatch table
if not Is_Parent (Iface, Typ) then
Append_To (Stmts_List,
Build_Set_Static_Offset_To_Top (Loc,
Iface_Tag =>
New_Reference_To (Iface_Tag, Loc),
Offset_Value =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Tag_Comp, Loc)),
Attribute_Name => Name_Position))));
end if;
-- Generate:
-- Set_Offset_To_Top
-- Register_Interface_Offset
-- (This => Init,
-- Interface_T => Iface'Tag,
-- Is_Constant => True,
-- Offset_Value => n,
-- Offset_Func => null);
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Set_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
if RTE_Available (RE_Register_Interface_Offset) then
Append_To (Stmts_List,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Register_Interface_Offset), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Iface))),
Loc)),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Iface))),
Loc)),
New_Occurrence_Of (Standard_True, Loc),
New_Occurrence_Of (Standard_True, Loc),
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Tag_Comp, Loc)),
Attribute_Name => Name_Position)),
Unchecked_Convert_To
(RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Tag_Comp, Loc)),
Attribute_Name => Name_Position)),
Make_Null (Loc))));
Make_Null (Loc))));
end if;
end if;
end Initialize_Tag;
......@@ -6816,6 +6875,32 @@ package body Exp_Ch3 is
Comp_Typ : Entity_Id;
Idx : Node_Id;
function Is_Constant_Bound (Exp : Node_Id) return Boolean;
-- To simplify handling of array components. Determines whether the
-- given bound is constant (a constant or enumeration literal, or an
-- integer literal) as opposed to per-object, through an expression
-- or a discriminant.
-----------------------
-- Is_Constant_Bound --
-----------------------
function Is_Constant_Bound (Exp : Node_Id) return Boolean is
begin
if Nkind (Exp) = N_Integer_Literal then
return True;
else
return
Is_Entity_Name (Exp)
and then Present (Entity (Exp))
and then
(Ekind (Entity (Exp)) = E_Constant
or else Ekind (Entity (Exp)) = E_Enumeration_Literal);
end if;
end Is_Constant_Bound;
-- Start of processing for Is_Variable_Sized_Record
begin
pragma Assert (Is_Record_Type (E));
......@@ -6840,15 +6925,9 @@ package body Exp_Ch3 is
Idx := First_Index (Comp_Typ);
while Present (Idx) loop
if Nkind (Idx) = N_Range then
if (Nkind (Low_Bound (Idx)) = N_Identifier
and then Present (Entity (Low_Bound (Idx)))
and then
Ekind (Entity (Low_Bound (Idx))) /= E_Constant)
or else
(Nkind (High_Bound (Idx)) = N_Identifier
and then Present (Entity (High_Bound (Idx)))
and then
Ekind (Entity (High_Bound (Idx))) /= E_Constant)
if not Is_Constant_Bound (Low_Bound (Idx))
or else
not Is_Constant_Bound (High_Bound (Idx))
then
return True;
end if;
......@@ -7506,6 +7585,7 @@ package body Exp_Ch3 is
if Ada_Version >= Ada_05
and then VM_Target = No_VM
and then RTE_Available (RE_Select_Specific_Data)
then
-- These primitives are defined abstract in interface types
......@@ -7608,8 +7688,14 @@ package body Exp_Ch3 is
-- initialization of its dispatch table.
or else (not Is_Interface (Tag_Typ)
and then
Is_Interface (Etype (Tag_Typ)))
and then Is_Interface (Etype (Tag_Typ)))
-- Ada 205 (AI-251): We must also generate these subprograms if
-- the parent of an nonlimited interface is a limited interface
or else (Is_Interface (Tag_Typ)
and then not Is_Limited_Interface (Tag_Typ)
and then Is_Limited_Interface (Etype (Tag_Typ)))
then
if not Is_Limited_Type (Tag_Typ) then
Append_To (Res,
......@@ -7999,6 +8085,7 @@ package body Exp_Ch3 is
and then Is_Limited_Record (Etype (Tag_Typ)))
or else (Is_Concurrent_Record_Type (Tag_Typ)
and then Has_Abstract_Interfaces (Tag_Typ)))
and then RTE_Available (RE_Select_Specific_Data)
then
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ));
......
gcc/ada/exp_ch3.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -133,16 +133,18 @@ package Exp_Ch3 is
function Get_Simple_Init_Val
(T : Entity_Id;
Loc : Source_Ptr;
N : Node_Id;
Size : Uint := No_Uint) return Node_Id;
-- For a type which Needs_Simple_Initialization (see above), prepares the
-- tree for an expression representing the required initial value. Loc is
-- the source location used in constructing this tree which is returned as
-- the result of the call. The Size parameter indicates the target size of
-- the object if it is known (indicated by a value that is not No_Uint and
-- is greater than zero). If Size is not given (Size set to No_Uint, or
-- non-positive), then the Esize of T is used as an estimate of the Size.
-- The object size is needed to prepare a known invalid value for use by
-- Normalize_Scalars.
-- tree for an expression representing the required initial value. N is a
-- node whose source location used in constructing this tree which is
-- returned as the result of the call. The Size parameter indicates the
-- target size of the object if it is known (indicated by a value that is
-- not No_Uint and is greater than zero). If Size is not given (Size set to
-- No_Uint, or non-positive), then the Esize of T is used as an estimate of
-- the Size. The object size is needed to prepare a known invalid value for
-- 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;
gcc/ada/exp_disp.adb
......@@ -99,7 +99,15 @@ package body Exp_Disp is
------------------------
function Building_Static_DT (Typ : Entity_Id) return Boolean is
Root_Typ : Entity_Id := Root_Type (Typ);
begin
-- Handle private types
if Present (Full_View (Root_Typ)) then
Root_Typ := Full_View (Root_Typ);
end if;
return Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ)
......@@ -107,7 +115,7 @@ package body Exp_Disp is
-- build the dispatch tables because we must inherit primitives
-- from the CPP side.
and then not Is_CPP_Class (Root_Type (Typ));
and then not Is_CPP_Class (Root_Typ);
end Building_Static_DT;
----------------------------------
......@@ -548,7 +556,6 @@ package body Exp_Disp is
Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
Set_Etype (Subp_Typ, Res_Typ);
Init_Size_Align (Subp_Ptr_Typ);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
-- Create a new list of parameters which is a copy of the old formal
......@@ -575,18 +582,11 @@ package body Exp_Disp is
Set_Etype (New_Formal, Etype (Param));
end if;
if Is_Itype (Etype (New_Formal)) then
Extra := New_Copy (Etype (New_Formal));
if Ekind (Extra) = E_Record_Subtype
or else Ekind (Extra) = E_Class_Wide_Subtype
then
Set_Cloned_Subtype (Extra, Etype (New_Formal));
end if;
Set_Etype (New_Formal, Extra);
Set_Scope (Etype (New_Formal), Subp_Typ);
end if;
-- If the type of the formal is an itype, there was code here
-- introduced in 1998 in revision 1.46, to create a new itype
-- by copy. This seems useless, and in fact leads to semantic
-- errors when the itype is the completion of a type derived
-- from a private type.
Extra := New_Formal;
Next_Formal (Old_Formal);
......@@ -780,7 +780,7 @@ package body Exp_Disp is
-- Give error if configurable run time and Displace not available
if not RTE_Available (RE_Displace) then
Error_Msg_CRT ("abstract interface types", N);
Error_Msg_CRT ("dynamic interface conversion", N);
return;
end if;
......@@ -839,9 +839,7 @@ package body Exp_Disp is
begin
New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
Set_Etype (New_Itype, New_Itype);
Init_Esize (New_Itype);
Init_Size_Align (New_Itype);
Set_Etype (New_Itype, New_Itype);
Set_Directly_Designated_Type (New_Itype, Etyp);
Rewrite (N,
......@@ -1205,6 +1203,8 @@ package body Exp_Disp is
Decl_1 : Node_Id;
Decl_2 : Node_Id;
Formal : Node_Id;
New_Arg : Node_Id;
Offset_To_Top : Node_Id;
Target : Entity_Id;
Target_Formal : Entity_Id;
......@@ -1212,13 +1212,6 @@ package body Exp_Disp is
Thunk_Id := Empty;
Thunk_Code := Empty;
-- Give message if configurable run-time and Offset_To_Top unavailable
if not RTE_Available (RE_Offset_To_Top) then
Error_Msg_CRT ("abstract interface types", Prim);
return;
end if;
-- Traverse the list of alias to find the final target
Target := Prim;
......@@ -1284,6 +1277,20 @@ package body Exp_Disp is
(Directly_Designated_Type
(Etype (Target_Formal)), Loc)));
New_Arg :=
Unchecked_Convert_To (RTE (RE_Address),
New_Reference_To (Defining_Identifier (Formal), Loc));
if not RTE_Available (RE_Offset_To_Top) then
Offset_To_Top :=
Build_Offset_To_Top (Loc, New_Arg);
else
Offset_To_Top :=
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (New_Arg));
end if;
Decl_1 :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
......@@ -1299,14 +1306,7 @@ package body Exp_Disp is
(RTE (RE_Storage_Offset),
New_Reference_To (Defining_Identifier (Formal), Loc)),
Right_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To
(RTE (RE_Address),
New_Reference_To
(Defining_Identifier (Formal), Loc))))));
Offset_To_Top));
Append_To (Decl, Decl_2);
Append_To (Decl, Decl_1);
......@@ -1326,6 +1326,23 @@ package body Exp_Disp is
-- - Offset_To_Top (Formal'Address)
-- S2 : Addr_Ptr := Addr_Ptr!(S1)
New_Arg :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Defining_Identifier (Formal), Loc),
Attribute_Name =>
Name_Address);
if not RTE_Available (RE_Offset_To_Top) then
Offset_To_Top :=
Build_Offset_To_Top (Loc, New_Arg);
else
Offset_To_Top :=
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (New_Arg));
end if;
Decl_1 :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
......@@ -1344,15 +1361,7 @@ package body Exp_Disp is
(Defining_Identifier (Formal), Loc),
Attribute_Name => Name_Address)),
Right_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Offset_To_Top), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To
(Defining_Identifier (Formal), Loc),
Attribute_Name => Name_Address)))));
Offset_To_Top));
Decl_2 :=
Make_Object_Declaration (Loc,
......@@ -3042,6 +3051,10 @@ package body Exp_Disp is
(Expression
(Parent (RTE (RE_Max_Predef_Prims)))));
DT_Decl : constant Elist_Id := New_Elmt_List;
DT_Aggr : constant Elist_Id := New_Elmt_List;
-- Entities marked with attribute Is_Dispatch_Table_Entity
procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
-- Verify that all non-tagged types in the profile of a subprogram
-- are frozen at the point the subprogram is frozen. This enforces
......@@ -3229,6 +3242,7 @@ package body Exp_Disp is
declare
Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
Decl : Node_Id;
Thunk_Id : Entity_Id;
Thunk_Code : Node_Id;
......@@ -3272,27 +3286,43 @@ package body Exp_Disp is
for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then
New_Node :=
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else
New_Node :=
New_Reference_To (RTE (RE_Null_Address), Loc);
New_Node := Make_Null (Loc);
end if;
Append_To (Prim_Ops_Aggr_List, New_Node);
end loop;
New_Node :=
Make_Aggregate (Loc,
Expressions => Prim_Ops_Aggr_List);
-- Remember aggregates initializing dispatch tables
Append_Elmt (New_Node, DT_Aggr);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('S')),
Subtype_Indication =>
New_Reference_To (RTE (RE_Address_Array), Loc));
Append_To (Result, Decl);
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims,
Constant_Present => Building_Static_DT (Typ),
Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc),
Expression => Make_Aggregate (Loc,
Expressions => Prim_Ops_Aggr_List)));
Object_Definition => New_Reference_To
(Defining_Identifier (Decl), Loc),
Expression => New_Node));
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
......@@ -3492,15 +3522,13 @@ package body Exp_Disp is
Prim_Ops_Aggr_List := New_List;
if Empty_DT then
Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc));
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
elsif Is_Abstract_Type (Typ)
or else not Building_Static_DT (Typ)
then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc));
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
end loop;
else
......@@ -3556,13 +3584,12 @@ package body Exp_Disp is
for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then
New_Node :=
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else
New_Node :=
New_Reference_To (RTE (RE_Null_Address), Loc);
New_Node := Make_Null (Loc);
end if;
Append_To (Prim_Ops_Aggr_List, New_Node);
......@@ -3570,9 +3597,15 @@ package body Exp_Disp is
end;
end if;
Append_To (DT_Aggr_List,
New_Node :=
Make_Aggregate (Loc,
Expressions => Prim_Ops_Aggr_List));
Expressions => Prim_Ops_Aggr_List);
Append_To (DT_Aggr_List, New_Node);
-- Remember aggregates initializing dispatch tables
Append_Elmt (New_Node, DT_Aggr);
Append_To (Result,
Make_Object_Declaration (Loc,
......@@ -3635,14 +3668,10 @@ package body Exp_Disp is
(RTE_Record_Component (RE_Predef_Prims), Loc)),
Attribute_Name => Name_Address)));
-- Mark entities containing library level static dispatch tables.
-- This attribute is later propagated to all the access-to-subprogram
-- itypes generated to fill the dispatch table slots (see exp_attr).
-- Remember entities containing dispatch tables
if Building_Static_DT (Typ) then
Set_Is_Static_Dispatch_Table_Entity (Predef_Prims);
Set_Is_Static_Dispatch_Table_Entity (Iface_DT);
end if;
Append_Elmt (Predef_Prims, DT_Decl);
Append_Elmt (Iface_DT, DT_Decl);
end Make_Secondary_DT;
-- Local variables
......@@ -3666,6 +3695,7 @@ package body Exp_Disp is
New_Node : Node_Id;
No_Reg : Node_Id;
Num_Ifaces : Nat := 0;
Parent_Typ : Entity_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Ops_Aggr_List : List_Id;
......@@ -3761,6 +3791,14 @@ package body Exp_Disp is
end if;
end if;
-- Initialize Parent_Typ handling private types
Parent_Typ := Etype (Typ);
if Present (Full_View (Parent_Typ)) then
Parent_Typ := Full_View (Parent_Typ);
end if;
-- Ensure that all the primitives are frozen. This is only required when
-- building static dispatch tables --- the primitives must be frozen to
-- be referenced (otherwise we have problems with the backend). It is
......@@ -4045,6 +4083,7 @@ package body Exp_Disp is
-- HT_Link => HT_Link'Address,
-- Transportable => <<boolean-value>>,
-- RC_Offset => <<integer-value>>,
-- [ Size_Func => Size_Prim'Access ]
-- [ Interfaces_Table => <<access-value>> ]
-- [ SSD => SSD_Table'Address ]
-- Tags_Table => (0 => null,
......@@ -4204,23 +4243,28 @@ package body Exp_Disp is
-- External tag of a library-level tagged type: Check for a definition
-- of External_Tag. The clause is considered only if it applies to this
-- specific tagged type, as opposed to one of its ancestors.
-- If the type is an unconstrained type extension, we are building the
-- dispatch table of its anonymous base type, so the external tag, if
-- any was specified, must be retrieved from the first subtype.
else
declare
Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ,
Attribute_External_Tag);
Def : constant Node_Id := Get_Attribute_Definition_Clause
(First_Subtype (Typ),
Attribute_External_Tag);
Old_Val : String_Id;
New_Val : String_Id;
E : Entity_Id;
begin
if not Present (Def)
or else Entity (Name (Def)) /= Typ
or else Entity (Name (Def)) /= First_Subtype (Typ)
then
New_Node :=
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Exname, Loc),
Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address));
else
Old_Val := Strval (Expr_Value_S (Expression (Def)));
......@@ -4320,15 +4364,8 @@ package body Exp_Disp is
declare
RC_Offset_Node : Node_Id;
Parent_Typ : Entity_Id;
begin
if Present (Full_View (Etype (Typ))) then
Parent_Typ := Full_View (Etype (Typ));
else
Parent_Typ := Etype (Typ);
end if;
if not Has_Controlled_Component (Typ) then
RC_Offset_Node := Make_Integer_Literal (Loc, 0);
......@@ -4368,6 +4405,52 @@ package body Exp_Disp is
Append_To (TSD_Aggr_List, RC_Offset_Node);
end;
-- Size_Func
if RTE_Record_Component_Available (RE_Size_Func) then
if not Building_Static_DT (Typ)
or else Is_Interface (Typ)
then
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Size_Ptr),
New_Reference_To (RTE (RE_Null_Address), Loc)));
else
declare
Prim_Elmt : Elmt_Id;
Prim : Entity_Id;
begin
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if Chars (Prim) = Name_uSize then
while Present (Alias (Prim)) loop
Prim := Alias (Prim);
end loop;
if Is_Abstract_Subprogram (Prim) then
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Size_Ptr),
New_Reference_To (RTE (RE_Null_Address), Loc)));
else
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Size_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access)));
end if;
exit;
end if;
Next_Elmt (Prim_Elmt);
end loop;
end;
end if;
end if;
-- Interfaces_Table (required for AI-405)
if RTE_Record_Component_Available (RE_Interfaces_Table) then
......@@ -4561,34 +4644,34 @@ package body Exp_Disp is
-- Initialize the table of ancestor tags. In case of interface types
-- this table is not needed.
declare
Current_Typ : Entity_Id;
Parent_Typ : Entity_Id;
Pos : Nat;
TSD_Tags_List := New_List;
begin
TSD_Tags_List := New_List;
-- If we are not statically allocating the dispatch table then we must
-- fill position 0 with null because we still have not generated the
-- tag of Typ.
-- If we are not statically allocating the dispatch table then we
-- must fill position 0 with null because we still have not
-- generated the tag of Typ.
if not Building_Static_DT (Typ)
or else Is_Interface (Typ)
then
Append_To (TSD_Tags_List,
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc)));
if not Building_Static_DT (Typ)
or else Is_Interface (Typ)
then
Append_To (TSD_Tags_List,
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (RTE (RE_Null_Address), Loc)));
-- Otherwise we can safely reference the tag
-- Otherwise we can safely reference the tag
else
Append_To (TSD_Tags_List,
New_Reference_To (DT_Ptr, Loc));
end if;
else
Append_To (TSD_Tags_List,
New_Reference_To (DT_Ptr, Loc));
end if;
-- Fill the rest of the table with the tags of the ancestors
-- Fill the rest of the table with the tags of the ancestors
declare
Current_Typ : Entity_Id;
Parent_Typ : Entity_Id;
Pos : Nat;
begin
Pos := 1;
Current_Typ := Typ;
......@@ -4775,6 +4858,7 @@ package body Exp_Disp is
declare
Prim_Table : array
(Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
Decl : Node_Id;
E : Entity_Id;
begin
......@@ -4808,26 +4892,43 @@ package body Exp_Disp is
for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then
New_Node :=
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else
New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
New_Node := Make_Null (Loc);
end if;
Append_To (Prim_Ops_Aggr_List, New_Node);
end loop;
New_Node :=
Make_Aggregate (Loc,
Expressions => Prim_Ops_Aggr_List);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
New_Internal_Name ('S')),
Subtype_Indication =>
New_Reference_To (RTE (RE_Address_Array), Loc));
Append_To (Result, Decl);
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims,
Aliased_Present => True,
Constant_Present => Building_Static_DT (Typ),
Object_Definition =>
New_Reference_To (RTE (RE_Address_Array), Loc),
Expression => Make_Aggregate (Loc,
Expressions => Prim_Ops_Aggr_List)));
Object_Definition => New_Reference_To
(Defining_Identifier (Decl), Loc),
Expression => New_Node));
-- Remember aggregates initializing dispatch tables
Append_Elmt (New_Node, DT_Aggr);
Append_To (Result,
Make_Attribute_Definition_Clause (Loc,
......@@ -4880,9 +4981,7 @@ package body Exp_Disp is
-- Offset_To_Top
if RTE_Record_Component_Available (RE_Offset_To_Top) then
Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
end if;
Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
-- Typeinfo
......@@ -4896,13 +4995,11 @@ package body Exp_Disp is
Prim_Ops_Aggr_List := New_List;
if Nb_Prim = 0 then
Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc));
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
elsif not Building_Static_DT (Typ) then
for J in 1 .. Nb_Prim loop
Append_To (Prim_Ops_Aggr_List,
New_Reference_To (RTE (RE_Null_Address), Loc));
Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
end loop;
else
......@@ -4951,12 +5048,12 @@ package body Exp_Disp is
for J in Prim_Table'Range loop
if Present (Prim_Table (J)) then
New_Node :=
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim_Table (J), Loc),
Attribute_Name => Name_Unrestricted_Access));
else
New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
New_Node := Make_Null (Loc);
end if;
Append_To (Prim_Ops_Aggr_List, New_Node);
......@@ -4964,9 +5061,15 @@ package body Exp_Disp is
end;
end if;
Append_To (DT_Aggr_List,
New_Node :=
Make_Aggregate (Loc,
Expressions => Prim_Ops_Aggr_List));
Expressions => Prim_Ops_Aggr_List);
Append_To (DT_Aggr_List, New_Node);
-- Remember aggregates initializing dispatch tables
Append_Elmt (New_Node, DT_Aggr);
-- In case of locally defined tagged types we have already declared
-- and uninitialized object for the dispatch table, which is now
......@@ -5048,26 +5151,27 @@ package body Exp_Disp is
-- If the ancestor is a CPP_Class type we inherit the dispatch tables
-- in the init proc, and we don't need to fill them in here.
elsif Is_CPP_Class (Etype (Typ)) then
elsif Is_CPP_Class (Parent_Typ) then
null;
-- Otherwise we fill in the dispatch tables here
else
if Typ /= Etype (Typ)
if Typ /= Parent_Typ
and then not Is_Interface (Typ)
and then not Restriction_Active (No_Dispatching_Calls)
then
-- Inherit the dispatch table
if not Is_Interface (Typ)
and then not Is_Interface (Etype (Typ))
and then not Is_CPP_Class (Etype (Typ))
and then not Is_Interface (Parent_Typ)
and then not Is_CPP_Class (Parent_Typ)
then
declare
Nb_Prims : constant Int :=
UI_To_Int (DT_Entry_Count
(First_Tag_Component (Etype (Typ))));
(First_Tag_Component (Parent_Typ)));
begin
Append_To (Elab_Code,
Build_Inherit_Predefined_Prims (Loc,
......@@ -5076,7 +5180,7 @@ package body Exp_Disp is
(Node
(Next_Elmt
(First_Elmt
(Access_Disp_Table (Etype (Typ))))), Loc),
(Access_Disp_Table (Parent_Typ)))), Loc),
New_Tag_Node =>
New_Reference_To
(Node
......@@ -5092,7 +5196,7 @@ package body Exp_Disp is
New_Reference_To
(Node
(First_Elmt
(Access_Disp_Table (Etype (Typ)))), Loc),
(Access_Disp_Table (Parent_Typ))), Loc),
New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
Num_Prims => Nb_Prims));
end if;
......@@ -5101,13 +5205,13 @@ package body Exp_Disp is
-- Inherit the secondary dispatch tables of the ancestor
if not Is_CPP_Class (Etype (Typ)) then
if not Is_CPP_Class (Parent_Typ) then
declare
Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table (Etype (Typ)))));
(Access_Disp_Table (Parent_Typ))));
Sec_DT_Typ : Elmt_Id :=
Next_Elmt
(Next_Elmt
......@@ -5327,18 +5431,49 @@ package body Exp_Disp is
Make_Select_Specific_Data_Table (Typ));
end if;
-- Mark entities containing library level static dispatch tables. This
-- attribute is later propagated to all the access-to-subprogram itypes
-- generated to fill the dispatch table slots (see exp_attr).
-- Remember entities containing dispatch tables
if Building_Static_DT (Typ) then
Set_Is_Static_Dispatch_Table_Entity (Predef_Prims);
Set_Is_Static_Dispatch_Table_Entity (DT);
end if;
Append_Elmt (Predef_Prims, DT_Decl);
Append_Elmt (DT, DT_Decl);
Analyze_List (Result, Suppress => All_Checks);
Set_Has_Dispatch_Table (Typ);
-- Mark entities containing dispatch tables. Required by the
-- backend to handle them properly.
if not Is_Interface (Typ) then
declare
Elmt : Elmt_Id;
begin
-- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
-- the decoration required by the backend
Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
-- Object declarations
Elmt := First_Elmt (DT_Decl);
while Present (Elmt) loop
Set_Is_Dispatch_Table_Entity (Node (Elmt));
pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
Next_Elmt (Elmt);
end loop;
-- Aggregates initializing dispatch tables
Elmt := First_Elmt (DT_Aggr);
while Present (Elmt) loop
Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
Next_Elmt (Elmt);
end loop;
end;
end if;
return Result;
end Make_DT;
......@@ -5763,7 +5898,7 @@ package body Exp_Disp is
-- expand dispatching calls through the primary dispatch table.
-- Generate:
-- type Typ_DT is array (1 .. Nb_Prims) of Address;
-- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
-- type Typ_DT_Acc is access Typ_DT;
declare
......@@ -5791,7 +5926,7 @@ package body Exp_Disp is
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Reference_To (RTE (RE_Address), Loc)))));
New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
Append_To (Result,
Make_Full_Type_Declaration (Loc,
......@@ -5810,6 +5945,11 @@ package body Exp_Disp is
Analyze_List (Result);
Set_Suppress_Init_Proc (Base_Type (DT_Prims));
-- Mark entity of dispatch table. Required by the backend to handle
-- the properly.
Set_Is_Dispatch_Table_Entity (DT_Prims);
end;
Set_Ekind (DT_Ptr, E_Constant);
......@@ -5949,9 +6089,9 @@ package body Exp_Disp is
L : List_Id;
Pos : Uint;
Tag : Entity_Id;
Tag_Typ : Entity_Id;
Thunk_Id : Entity_Id;
Thunk_Code : Node_Id;
Typ : Entity_Id;
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
......@@ -5961,35 +6101,49 @@ package body Exp_Disp is
end if;
if not Present (Abstract_Interface_Alias (Prim)) then
Typ := Scope (DTC_Entity (Prim));
Tag_Typ := Scope (DTC_Entity (Prim));
Pos := DT_Position (Prim);
Tag := First_Tag_Component (Typ);
Tag := First_Tag_Component (Tag_Typ);
if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim)
then
DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
DT_Ptr :=
Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
Insert_After (Ins_Nod,
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
-- Register copy of the pointer to the 'size primitive in the TSD.
if Chars (Prim) = Name_uSize
and then RTE_Record_Component_Available (RE_Size_Func)
then
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
Insert_After (Ins_Nod,
Build_Set_Size_Function (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Size_Func => Prim));
end if;
else
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
Insert_After (Ins_Nod,
Build_Set_Prim_Op_Address (Loc,
Typ => Typ,
Typ => Tag_Typ,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
......@@ -6002,14 +6156,14 @@ package body Exp_Disp is
-- else to do here.
else
Typ := Find_Dispatching_Type (Alias (Prim));
Tag_Typ := Find_Dispatching_Type (Alias (Prim));
Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
pragma Assert (Is_Interface (Iface_Typ));
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if not Is_Parent (Iface_Typ, Typ)
if not Is_Parent (Iface_Typ, Tag_Typ)
and then Present (Thunk_Code)
then
-- Comment needed on why checks are suppressed. This is not just
......@@ -6022,7 +6176,7 @@ package body Exp_Disp is
-- the secondary dispatch table of Prim's controlling type with
-- Thunk_Id's address.
Iface_DT_Elmt := Find_Interface_ADT (Typ, Iface_Typ);
Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
Iface_DT_Ptr := Node (Iface_DT_Elmt);
pragma Assert (Has_Thunks (Iface_DT_Ptr));
......@@ -6040,7 +6194,7 @@ package body Exp_Disp is
New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
Position => Pos,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
......@@ -6056,7 +6210,7 @@ package body Exp_Disp is
New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
Position => Pos,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
......@@ -6073,7 +6227,7 @@ package body Exp_Disp is
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
Position => Pos,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
......@@ -6089,7 +6243,7 @@ package body Exp_Disp is
Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
Position => Pos,
Address_Node =>
Unchecked_Convert_To (RTE (RE_Address),
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
......
gcc/ada/rtsfind.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -283,6 +283,9 @@ package body Rtsfind is
if U_Id in Ada_Calendar_Child then
Name_Buffer (13) := '.';
elsif U_Id in Ada_Dispatching_Child then
Name_Buffer (16) := '.';
elsif U_Id in Ada_Finalization_Child then
Name_Buffer (17) := '.';
......@@ -311,6 +314,10 @@ package body Rtsfind is
elsif U_Id in System_Child then
Name_Buffer (7) := '.';
if U_Id in System_Strings_Child then
Name_Buffer (15) := '.';
end if;
if U_Id in System_Tasking_Child then
Name_Buffer (15) := '.';
end if;
......
gcc/ada/rtsfind.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -78,6 +78,9 @@ package Rtsfind is
-- name is System.xxx. For example, the name System_Str_Concat refers to
-- package System.Str_Concat.
-- Names of the form System_Strings_xxx are second level children of the
-- package System.Strings.
-- Names of the form System_Tasking_xxx are second level children of the
-- package System.Tasking. For example, System_Tasking_Stages refers to
-- refers to the package System.Tasking.Stages.
......@@ -112,6 +115,7 @@ package Rtsfind is
-- Children of Ada
Ada_Calendar,
Ada_Dispatching,
Ada_Exceptions,
Ada_Finalization,
Ada_Interrupts,
......@@ -125,6 +129,10 @@ package Rtsfind is
Ada_Calendar_Delays,
-- Children of Ada.Dispatching
Ada_Dispatching_EDF,
-- Children of Ada.Finalization
Ada_Finalization_List_Controller,
......@@ -348,6 +356,10 @@ package Rtsfind is
System_WWd_Enum,
System_WWd_Wchar,
-- Children of System.Strings
System_Strings_Stream_Ops,
-- Children of System.Tasking
System_Tasking_Async_Delays,
......@@ -369,6 +381,10 @@ package Rtsfind is
range Ada_Calendar_Delays .. Ada_Calendar_Delays;
-- Range of values for children of Ada.Calendar
subtype Ada_Dispatching_Child is RTU_Id
range Ada_Dispatching_EDF .. Ada_Dispatching_EDF;
-- Range of values for children of Ada.Dispatching
subtype Ada_Finalization_Child is Ada_Child range
Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller;
-- Range of values for children of Ada.Finalization
......@@ -404,6 +420,9 @@ package Rtsfind is
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
subtype System_Strings_Child is RTU_Id
range System_Strings_Stream_Ops .. System_Strings_Stream_Ops;
subtype System_Tasking_Child is System_Child
range System_Tasking_Async_Delays .. System_Tasking_Stages;
-- Range of values for children of System.Tasking
......@@ -451,6 +470,8 @@ package Rtsfind is
RE_Null,
RE_Set_Deadline, -- Ada.Dispatching.EDF
RE_Code_Loc, -- Ada.Exceptions
RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only)
RE_Exception_Id, -- Ada.Exceptions
......@@ -497,6 +518,7 @@ package Rtsfind is
RE_Dispatch_Table_Wrapper, -- Ada.Tags
RE_Displace, -- Ada.Tags
RE_DT, -- Ada.Tags
RE_DT_Offset_To_Top_Offset, -- Ada.Tags
RE_DT_Predef_Prims_Offset, -- Ada.Tags
RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags
RE_External_Tag, -- Ada.Tags
......@@ -520,6 +542,7 @@ package Rtsfind is
RE_Num_Prims, -- Ada.Tags
RE_Object_Specific_Data, -- Ada.Tags
RE_Offset_To_Top, -- Ada.Tags
RE_Offset_To_Top_Ptr, -- Ada.Tags
RE_Offset_To_Top_Function_Ptr, -- Ada.Tags
RE_OSD_Table, -- Ada.Tags
RE_OSD_Num_Prims, -- Ada.Tags
......@@ -534,20 +557,24 @@ package Rtsfind is
RE_Predef_Prims, -- Ada.Tags
RE_Predef_Prims_Table_Ptr, -- Ada.Tags
RE_Prim_Op_Kind, -- Ada.Tags
RE_Prim_Ptr, -- Ada.Tags
RE_Prims_Ptr, -- Ada.Tags
RE_Primary_DT, -- Ada.Tags
RE_Signature, -- Ada.Tags
RE_SSD, -- Ada.Tags
RE_TSD, -- Ada.Tags
RE_Type_Specific_Data, -- Ada.Tags
RE_Register_Interface_Offset, -- Ada.Tags
RE_Register_Tag, -- Ada.Tags
RE_Transportable, -- Ada.Tags
RE_Secondary_DT, -- Ada.Tags
RE_Secondary_Tag, -- Ada.Tags
RE_Select_Specific_Data, -- Ada.Tags
RE_Set_Entry_Index, -- Ada.Tags
RE_Set_Offset_To_Top, -- Ada.Tags
RE_Set_Dynamic_Offset_To_Top, -- Ada.Tags
RE_Set_Prim_Op_Kind, -- Ada.Tags
RE_Size_Func, -- Ada.Tags
RE_Size_Ptr, -- Ada.Tags
RE_Tag, -- Ada.Tags
RE_Tag_Error, -- Ada.Tags
RE_Tag_Kind, -- Ada.Tags
......@@ -573,6 +600,9 @@ package Rtsfind is
RO_CA_Delay_Until, -- Ada.Calendar.Delays
RO_CA_To_Duration, -- Ada.Calendar.Delays
RE_Clock, -- Ada.Real_Time
RE_Time_Span, -- Ada.Real_Time
RE_Time_Span_Zero, -- Ada.Real_Time
RO_RT_Time, -- Ada.Real_Time
RO_RT_Delay_Until, -- Ada.Real_Time.Delays
......@@ -749,6 +779,7 @@ package Rtsfind is
RE_Default_Interrupt_Priority, -- System.Interrupts
RE_Dynamic_Interrupt_Protection, -- System.Interrupts
RE_Install_Handlers, -- System.Interrupts
RE_Install_Restricted_Handlers, -- System.Interrupts
RE_Register_Interrupt_Handler, -- System.Interrupts
RE_Static_Interrupt_Protection, -- System.Interrupts
RE_System_Interrupt_Id, -- System.Interrupts
......@@ -1233,11 +1264,10 @@ package Rtsfind is
RE_Storage_Offset, -- System.Storage_Elements
RE_Storage_Array, -- System.Storage_Elements
RE_To_Address, -- System.Storage_Elements
RE_Dummy_Communication_Block, -- System.Storage_Elements
RE_Root_Storage_Pool, -- System.Storage_Pools
RE_Allocate_Any, -- System_Storage_Pools,
RE_Deallocate_Any, -- System_Storage_Pools,
RE_Allocate_Any, -- System.Storage_Pools,
RE_Deallocate_Any, -- System.Storage_Pools,
RE_I_AD, -- System.Stream_Attributes
RE_I_AS, -- System.Stream_Attributes
......@@ -1292,6 +1322,19 @@ package Rtsfind is
RE_Str_Concat_5, -- System.String_Ops_Concat_5
RE_String_Input, -- System.Strings.Stream_Ops
RE_String_Output, -- System.Strings.Stream_Ops
RE_String_Read, -- System.Strings.Stream_Ops
RE_String_Write, -- System.Strings.Stream_Ops
RE_Wide_String_Input, -- System.Strings.Stream_Ops
RE_Wide_String_Output, -- System.Strings.Stream_Ops
RE_Wide_String_Read, -- System.Strings.Stream_Ops
RE_Wide_String_Write, -- System.Strings.Stream_Ops
RE_Wide_Wide_String_Input, -- System.Strings.Stream_Ops
RE_Wide_Wide_String_Output, -- System.Strings.Stream_Ops
RE_Wide_Wide_String_Read, -- System.Strings.Stream_Ops
RE_Wide_Wide_String_Write, -- System.Strings.Stream_Ops
RE_Task_Info_Type, -- System.Task_Info
RE_Unspecified_Task_Info, -- System.Task_Info
......@@ -1331,6 +1374,7 @@ package Rtsfind is
RE_Abort_Undefer, -- System.Soft_Links
RE_Complete_Master, -- System.Soft_Links
RE_Current_Master, -- System.Soft_Links
RE_Dummy_Communication_Block, -- System.Soft_Links
RE_Enter_Master, -- System.Soft_Links
RE_Get_Current_Excep, -- System.Soft_Links
RE_Get_GNAT_Exception, -- System.Soft_Links
......@@ -1555,6 +1599,8 @@ package Rtsfind is
RE_Null => RTU_Null,
RE_Set_Deadline => Ada_Dispatching_EDF,
RE_Code_Loc => Ada_Exceptions,
RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT
RE_Exception_Id => Ada_Exceptions,
......@@ -1601,6 +1647,7 @@ package Rtsfind is
RE_Dispatch_Table_Wrapper => Ada_Tags,
RE_Displace => Ada_Tags,
RE_DT => Ada_Tags,
RE_DT_Offset_To_Top_Offset => Ada_Tags,
RE_DT_Predef_Prims_Offset => Ada_Tags,
RE_DT_Typeinfo_Ptr_Size => Ada_Tags,
RE_External_Tag => Ada_Tags,
......@@ -1624,6 +1671,7 @@ package Rtsfind is
RE_Num_Prims => Ada_Tags,
RE_Object_Specific_Data => Ada_Tags,
RE_Offset_To_Top => Ada_Tags,
RE_Offset_To_Top_Ptr => Ada_Tags,
RE_Offset_To_Top_Function_Ptr => Ada_Tags,
RE_OSD_Table => Ada_Tags,
RE_OSD_Num_Prims => Ada_Tags,
......@@ -1638,20 +1686,24 @@ package Rtsfind is
RE_Predef_Prims => Ada_Tags,
RE_Predef_Prims_Table_Ptr => Ada_Tags,
RE_Prim_Op_Kind => Ada_Tags,
RE_Prim_Ptr => Ada_Tags,
RE_Prims_Ptr => Ada_Tags,
RE_Primary_DT => Ada_Tags,
RE_Signature => Ada_Tags,
RE_SSD => Ada_Tags,
RE_TSD => Ada_Tags,
RE_Type_Specific_Data => Ada_Tags,
RE_Register_Interface_Offset => Ada_Tags,
RE_Register_Tag => Ada_Tags,
RE_Transportable => Ada_Tags,
RE_Secondary_DT => Ada_Tags,
RE_Secondary_Tag => Ada_Tags,
RE_Select_Specific_Data => Ada_Tags,
RE_Set_Entry_Index => Ada_Tags,
RE_Set_Offset_To_Top => Ada_Tags,
RE_Set_Dynamic_Offset_To_Top => Ada_Tags,
RE_Set_Prim_Op_Kind => Ada_Tags,
RE_Size_Func => Ada_Tags,
RE_Size_Ptr => Ada_Tags,
RE_Tag => Ada_Tags,
RE_Tag_Error => Ada_Tags,
RE_Tag_Kind => Ada_Tags,
......@@ -1676,6 +1728,9 @@ package Rtsfind is
RO_CA_Delay_Until => Ada_Calendar_Delays,
RO_CA_To_Duration => Ada_Calendar_Delays,
RE_Clock => Ada_Real_Time,
RE_Time_Span => Ada_Real_Time,
RE_Time_Span_Zero => Ada_Real_Time,
RO_RT_Time => Ada_Real_Time,
RO_RT_Delay_Until => Ada_Real_Time_Delays,
RO_RT_To_Duration => Ada_Real_Time_Delays,
......@@ -1851,6 +1906,7 @@ package Rtsfind is
RE_Default_Interrupt_Priority => System_Interrupts,
RE_Dynamic_Interrupt_Protection => System_Interrupts,
RE_Install_Handlers => System_Interrupts,
RE_Install_Restricted_Handlers => System_Interrupts,
RE_Register_Interrupt_Handler => System_Interrupts,
RE_Static_Interrupt_Protection => System_Interrupts,
RE_System_Interrupt_Id => System_Interrupts,
......@@ -2335,7 +2391,6 @@ package Rtsfind is
RE_Storage_Offset => System_Storage_Elements,
RE_Storage_Array => System_Storage_Elements,
RE_To_Address => System_Storage_Elements,
RE_Dummy_Communication_Block => System_Storage_Elements,
RE_Root_Storage_Pool => System_Storage_Pools,
RE_Allocate_Any => System_Storage_Pools,
......@@ -2394,6 +2449,19 @@ package Rtsfind is
RE_Str_Concat_5 => System_String_Ops_Concat_5,
RE_String_Input => System_Strings_Stream_Ops,
RE_String_Output => System_Strings_Stream_Ops,
RE_String_Read => System_Strings_Stream_Ops,
RE_String_Write => System_Strings_Stream_Ops,
RE_Wide_String_Input => System_Strings_Stream_Ops,
RE_Wide_String_Output => System_Strings_Stream_Ops,
RE_Wide_String_Read => System_Strings_Stream_Ops,
RE_Wide_String_Write => System_Strings_Stream_Ops,
RE_Wide_Wide_String_Input => System_Strings_Stream_Ops,
RE_Wide_Wide_String_Output => System_Strings_Stream_Ops,
RE_Wide_Wide_String_Read => System_Strings_Stream_Ops,
RE_Wide_Wide_String_Write => System_Strings_Stream_Ops,
RE_Task_Info_Type => System_Task_Info,
RE_Unspecified_Task_Info => System_Task_Info,
......@@ -2433,6 +2501,7 @@ package Rtsfind is
RE_Abort_Undefer => System_Soft_Links,
RE_Complete_Master => System_Soft_Links,
RE_Current_Master => System_Soft_Links,
RE_Dummy_Communication_Block => System_Soft_Links,
RE_Enter_Master => System_Soft_Links,
RE_Get_Current_Excep => System_Soft_Links,
RE_Get_GNAT_Exception => System_Soft_Links,
......
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