-- --
-- 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- --
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 --
-------------------------------
begin
Len := 1;
- while Str (Len) /= ASCII.Nul loop
+ while Str (Len) /= ASCII.NUL loop
Len := Len + 1;
end loop;
-- 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;
----------------
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 --
------------------
-- 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 --
-- --
-- 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 --
-- 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
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
-- 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
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
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;
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;
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);
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
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
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);
-- 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
-- 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.
-- 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;
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));
-- --
-- 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- --
-- 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
-- --
-- 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- --
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;
-- 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 --
------------------------------------------------
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;
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 --
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 --
---------------
-- --
-- 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- --
-- 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;
--
-- 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;
-- --
-- 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- --
-- 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
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
elsif Ekind (E_Scope) = E_Subprogram_Body then
E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
-
end if;
S := Current_Scope;
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;
-------------------------------------------
-- --
-- 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- --
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);
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);
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));
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);
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
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;
end if;
Id := First_Component (Rec_Id);
-
while Present (Id) loop
Comp_Decl := Parent (Id);
Typ := Etype (Id);
-- 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
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));
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);
-- Ri1 : Index;
-- begin
+
+ -- if Left_Hi < Left_Lo then
+ -- return;
+ -- end if;
+
-- if Rev then
-- Li1 := Left_Hi;
-- Ri1 := Right_Hi;
-- 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;
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
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;
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),
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 =>
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
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;
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);
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;
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
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;
-- 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
-- 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
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
-- 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.
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
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
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
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),
(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,
-- 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;
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));
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;
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
-- 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,
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));
-- --
-- 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- --
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;
------------------------
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)
-- 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;
----------------------------------
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
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);
-- 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;
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,
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;
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;
(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 =>
(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);
-- - 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 =>
(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,
(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
declare
Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
+ Decl : Node_Id;
Thunk_Id : Entity_Id;
Thunk_Code : Node_Id;
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,
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
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;
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,
(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
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;
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
-- 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,
-- 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)));
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);
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
-- 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;
declare
Prim_Table : array
(Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
+ Decl : Node_Id;
E : Entity_Id;
begin
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,
-- 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
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
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;
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
-- 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,
(Node
(Next_Elmt
(First_Elmt
- (Access_Disp_Table (Etype (Typ))))), Loc),
+ (Access_Disp_Table (Parent_Typ)))), Loc),
New_Tag_Node =>
New_Reference_To
(Node
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;
-- 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
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;
-- 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
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,
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);
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));
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))));
-- 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
-- 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));
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))));
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))));
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))));
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))));
-- --
-- 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- --
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) := '.';
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;
-- --
-- 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- --
-- 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.
-- Children of Ada
Ada_Calendar,
+ Ada_Dispatching,
Ada_Exceptions,
Ada_Finalization,
Ada_Interrupts,
Ada_Calendar_Delays,
+ -- Children of Ada.Dispatching
+
+ Ada_Dispatching_EDF,
+
-- Children of Ada.Finalization
Ada_Finalization_List_Controller,
System_WWd_Enum,
System_WWd_Wchar,
+ -- Children of System.Strings
+
+ System_Strings_Stream_Ops,
+
-- Children of System.Tasking
System_Tasking_Async_Delays,
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
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
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
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
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
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
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
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
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
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
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
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,
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,
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,
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,
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,
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,
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_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,
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,
OSDN Git Service
