diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2006-02-15 09:38:00 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2006-02-15 09:38:00 +0000 |
commit | c6eb017a825a226c0506e038e5a0722e833892e5 (patch) | |
tree | 20310562d97b1530165e6f9980e07e7470bf0d34 /gcc/ada/a-tags.adb | |
parent | 18a40e9785d07da1e1f40b2a3a1c63144a40b64b (diff) | |
download | gcc-c6eb017a825a226c0506e038e5a0722e833892e5.tar.gz |
2006-02-13 Javier Miranda <miranda@adacore.com>
Gary Dismukes <dismukes@adacore.com>
* exp_ch3.adb (Component_Needs_Simple_Initialization): Add check for
availability of RE_Interface_Tag.
(Build_Initialization_Call): Fix wrong access to the discriminant value.
(Freeze_Record_Type): Do not generate the tables associated with
timed and conditional dispatching calls through synchronized
interfaces if compiling under No_Dispatching_Calls restriction.
When compiling for Ada 2005, for a nonabstract
type with a null extension, call Make_Controlling_Function_Wrappers
and insert the wrapper function declarations and bodies (the latter
being appended as freeze actions).
(Predefined_Primitive_Bodies): Do not generate the bodies of the
predefined primitives associated with timed and conditional
dispatching calls through synchronized interfaces if we are
compiling under No_Dispatching_Calls.
(Build_Init_Procedure): Use RTE_Available to check if a run-time
service is available before generating a call.
(Make_Controlling_Function_Wrappers): New procedure.
(Expand_N_Full_Type_Declaration): Create a class-wide master for
access-to-limited-interfaces because they can be used to reference
tasks that implement such limited interface.
(Build_Offset_To_Top_Functions): Build the tree corresponding to the
procedure spec and body of the Offset_To_Top function that is generated
when the parent of a type with discriminants has secondary dispatch
tables.
(Init_Secondary_Tags): Handle the case in which the parent of the type
containing secondary dispatch tables has discriminants to generate the
correct arguments to call Set_Offset_To_Top.
(Build_Record_Init_Proc): Add call to Build_Offset_To_Top_Functions.
* a-tags.ads, a-tags.adb: (Check_Index): Removed.
Add Wide_[Wide_]Expanded_Name.
(Get_Predefined_Prim_Op_Address): New subprogram that provides exactly
the same functionality of Get_Prim_Op_Address but applied to predefined
primitive operations because the pointers to the predefined primitives
are now saved in a separate table.
(Parent_Size): Modified to get access to the separate table of primitive
operations or the parent type.
(Set_Predefined_Prim_Op_Address): New subprogram that provides the same
functionality of Set_Prim_Op_Address but applied to predefined primitive
operations.
(Set_Signature): New subprogram used to store the signature of a DT.
(Displace): If the Offset_To_Top value is not static then call the
function generated by the expander to get such value; otherwise use
the value stored in the table of interfaces.
(Offset_To_Top): The type of the actual has been changed to Address to
give the correct support to tagged types with discriminants. In this
case this value is stored just immediately after the tag field.
(Set_Offset_To_Top): Two new formals have been added to indicate if the
offset_to_top value is static and hence pass this value to the run-time
to store it in the table of interfaces, or else if this value is dynamic
and then pass to the run-time the address of a function that is
generated by the expander to provide this value for each object of the
type.
* rtsfind.ads (Default_Prin_Op_Count): Removed.
(Default_Prim_Op_Count): New entity
(Get_Predefined_Prim_Op_Address): New entity
(Set_Predefined_Prim_Op_Address): New entity
(RE_Set_Signature): New entity
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111059 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/a-tags.adb')
-rw-r--r-- | gcc/ada/a-tags.adb | 248 |
1 files changed, 178 insertions, 70 deletions
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index a8d6cd00109..cfce83451b5 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -34,6 +34,8 @@ with Ada.Exceptions; with System.HTable; with System.Storage_Elements; use System.Storage_Elements; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; pragma Elaborate_All (System.HTable); @@ -42,6 +44,10 @@ package body Ada.Tags is -- Structure of the GNAT Primary Dispatch Table -- +----------------------+ +-- | table of | +-- : predefined primitive : +-- | ops pointers | +-- +----------------------+ -- | Signature | -- +----------------------+ -- | Tagged_Kind | @@ -66,8 +72,6 @@ package body Ada.Tags is -- +-------------------+ -- | num prim ops | -- +-------------------+ --- | num interfaces | --- +-------------------+ -- | Ifaces_Table_Ptr --> Interface Data -- +-------------------+ +------------+ -- Select Specific Data <---- SSD_Ptr | | table | @@ -84,6 +88,10 @@ package body Ada.Tags is -- Structure of the GNAT Secondary Dispatch Table -- +-----------------------+ +-- | table of | +-- : predefined primitive : +-- | ops pointers | +-- +-----------------------+ -- | Signature | -- +-----------------------+ -- | Tagged_Kind | @@ -126,9 +134,9 @@ package body Ada.Tags is -- Field_Type_Ptr in A-Tags.ads. -- Define the specifications of Get_<Field_Name> and Set_<Field_Name> - -- in A-Tags.ads. + -- in a-tags.ads. - -- Update the GNAT Dispatch Table structure in A-Tags.adb + -- Update the GNAT Dispatch Table structure in a-tags.adb -- Provide bodies to the Get_<Field_Name> and Set_<Field_Name> routines. -- The profile of a Get_<Field_Name> routine should resemble: @@ -184,9 +192,16 @@ package body Ada.Tags is -- Declarations for the table of interfaces type Interface_Data_Element is record - Iface_Tag : Tag; - Offset : System.Storage_Elements.Storage_Offset; + Iface_Tag : Tag; + Static_Offset_To_Top : Boolean; + Offset_To_Top_Value : System.Storage_Elements.Storage_Offset; + Offset_To_Top_Func : System.Address; end record; + -- If some ancestor of the tagged type has discriminants the field + -- Static_Offset_To_Top is False and the field Offset_To_Top_Func + -- is used to store the address of the function generated by the + -- expander which provides this value; otherwise Static_Offset_To_Top + -- is True and such value is stored in the Offset_To_Top_Value field. type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; @@ -322,9 +337,6 @@ package body Ada.Tags is -- only to declare the corresponding access type. end record; - -- Run-time check types and subprograms: These subprograms are used only - -- when the run-time is compiled with assertions enabled. - type Signature_Type is (Must_Be_Primary_DT, Must_Be_Secondary_DT, @@ -356,6 +368,17 @@ package body Ada.Tags is function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size); -- The profile of the implicitly defined _size primitive + type Offset_To_Top_Function_Ptr is + access function (This : System.Address) + return System.Storage_Elements.Storage_Offset; + -- Type definition used to call the function that is generated by the + -- expander in case of tagged types with discriminants that have secondary + -- dispatch tables. This function provides the Offset_To_Top value in this + -- specific case. + + function To_Offset_To_Top_Function_Ptr is + new Unchecked_Conversion (System.Address, Offset_To_Top_Function_Ptr); + type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset; function To_Storage_Offset_Ptr is @@ -365,11 +388,6 @@ package body Ada.Tags is -- Local Subprograms -- ----------------------- - function Check_Index - (T : Tag; - Index : Natural) return Boolean; - -- Check that Index references a valid entry of the dispatch table of T - function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean; -- Check that the signature of T is valid and corresponds with the subset -- specified by the signature Kind. @@ -489,20 +507,6 @@ package body Ada.Tags is end HTable_Subprograms; - ----------------- - -- Check_Index -- - ----------------- - - function Check_Index - (T : Tag; - Index : Natural) return Boolean - is - Max_Entries : constant Natural := Get_Num_Prim_Ops (T); - - begin - return Index /= 0 and then Index <= Max_Entries; - end Check_Index; - --------------------- -- Check_Signature -- --------------------- @@ -624,7 +628,7 @@ package body Ada.Tags is pragma Assert (Check_Signature (T, Must_Be_Interface)); - Obj_Base := This - Offset_To_Top (Curr_DT); + Obj_Base := This - Offset_To_Top (This); Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert @@ -636,8 +640,25 @@ package body Ada.Tags is if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop if Iface_Table.Table (Id).Iface_Tag = T then - Obj_Base := Obj_Base + Iface_Table.Table (Id).Offset; - Obj_DT := To_Tag_Ptr (Obj_Base).all; + + -- Case of Static value of Offset_To_Top + + if Iface_Table.Table (Id).Static_Offset_To_Top then + Obj_Base := + Obj_Base + Iface_Table.Table (Id).Offset_To_Top_Value; + + -- Otherwise we call the function generated by the expander + -- to provide us with this value + + else + Obj_Base := + Obj_Base + + To_Offset_To_Top_Function_Ptr + (Iface_Table.Table (Id).Offset_To_Top_Func).all + (Obj_Base); + end if; + + Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert (Check_Signature (Obj_DT, Must_Be_Secondary_DT)); @@ -680,7 +701,7 @@ package body Ada.Tags is pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface)); - Obj_Base := This - Offset_To_Top (Curr_DT); + Obj_Base := This - Offset_To_Top (This); Obj_DT := To_Tag_Ptr (Obj_Base).all; pragma Assert @@ -782,12 +803,10 @@ package body Ada.Tags is --------------------- function Get_Entry_Index (T : Tag; Position : Positive) return Positive is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return SSD (T).SSD_Table (Index).Index; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return SSD (T).SSD_Table (Position).Index; end Get_Entry_Index; ---------------------- @@ -815,6 +834,21 @@ package body Ada.Tags is end if; end Get_Num_Prim_Ops; + -------------------------------- + -- Get_Predef_Prim_Op_Address -- + -------------------------------- + + function Get_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive) return System.Address + is + Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size); + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert (Position <= Default_Prim_Op_Count); + return Prim_Ops_DT.Prims_Ptr (Position); + end Get_Predefined_Prim_Op_Address; + ------------------------- -- Get_Prim_Op_Address -- ------------------------- @@ -825,7 +859,7 @@ package body Ada.Tags is is begin pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); return T.Prims_Ptr (Position); end Get_Prim_Op_Address; @@ -837,12 +871,10 @@ package body Ada.Tags is (T : Tag; Position : Positive) return Prim_Op_Kind is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return SSD (T).SSD_Table (Index).Kind; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return SSD (T).SSD_Table (Position).Kind; end Get_Prim_Op_Kind; ---------------------- @@ -853,12 +885,10 @@ package body Ada.Tags is (T : Tag; Position : Positive) return Positive is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - return OSD (T).OSD_Table (Index); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + return OSD (T).OSD_Table (Position); end Get_Offset_Index; ------------------- @@ -898,6 +928,9 @@ package body Ada.Tags is ---------------- procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is + Old_T_Prim_Ops : Tag; + New_T_Prim_Ops : Tag; + Size : Positive; begin pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT)); pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT)); @@ -906,6 +939,11 @@ package body Ada.Tags is if Old_T /= null then New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count); + Old_T_Prim_Ops := To_Tag (To_Address (Old_T) - DT_Prologue_Size); + New_T_Prim_Ops := To_Tag (To_Address (New_T) - DT_Prologue_Size); + Size := Default_Prim_Op_Count; + New_T_Prim_Ops.Prims_Ptr (1 .. Size) := + Old_T_Prim_Ops.Prims_Ptr (1 .. Size); end if; end Inherit_DT; @@ -1034,12 +1072,18 @@ package body Ada.Tags is ------------------- function Offset_To_Top - (T : Tag) return System.Storage_Elements.Storage_Offset + (This : System.Address) return System.Storage_Elements.Storage_Offset is - Offset_To_Top : constant Storage_Offset_Ptr := - To_Storage_Offset_Ptr - (To_Address (T) - K_Offset_To_Top); + Curr_DT : constant Tag := To_Tag_Ptr (This).all; + Offset_To_Top : Storage_Offset_Ptr; begin + Offset_To_Top := To_Storage_Offset_Ptr + (To_Address (Curr_DT) - K_Offset_To_Top); + + if Offset_To_Top.all = SSE.Storage_Offset'Last then + Offset_To_Top := To_Storage_Offset_Ptr (This + Tag_Size); + end if; + return Offset_To_Top.all; end Offset_To_Top; @@ -1066,14 +1110,18 @@ package body Ada.Tags is Parent_Tag : Tag; -- The tag of the parent type through the dispatch table + Prim_Ops_DT : Tag; + -- The table of primitive operations of the parent + F : Acc_Size; -- Access to the _size primitive of the parent. We assume that it is -- always in the first slot of the dispatch table. begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - Parent_Tag := TSD (T).Tags_Table (1); - F := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); + Parent_Tag := TSD (T).Tags_Table (1); + Prim_Ops_DT := To_Tag (To_Address (Parent_Tag) - DT_Prologue_Size); + F := To_Acc_Size (Prim_Ops_DT.Prims_Ptr (1)); -- Here we compute the size of the _parent field of the object @@ -1156,12 +1204,10 @@ package body Ada.Tags is Position : Positive; Value : Positive) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - SSD (T).SSD_Table (Index).Index := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + SSD (T).SSD_Table (Position).Index := Value; end Set_Entry_Index; ----------------------- @@ -1219,12 +1265,10 @@ package body Ada.Tags is Position : Positive; Value : Positive) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - OSD (T).OSD_Table (Index) := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + OSD (T).OSD_Table (Position) := Value; end Set_Offset_Index; ----------------------- @@ -1234,7 +1278,9 @@ package body Ada.Tags is procedure Set_Offset_To_Top (This : System.Address; Interface_T : Tag; - Offset_Value : System.Storage_Elements.Storage_Offset) + Is_Static : Boolean; + Offset_Value : System.Storage_Elements.Storage_Offset; + Offset_Func : System.Address) is Prim_DT : Tag; Sec_Base : System.Address; @@ -1257,7 +1303,7 @@ package body Ada.Tags is -- "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 := To_Tag_Ptr (This).all; + Prim_DT := To_Tag_Ptr (This).all; pragma Assert (Check_Signature (Prim_DT, Must_Be_Primary_DT)); @@ -1268,9 +1314,13 @@ package body Ada.Tags is To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top); pragma Assert - (Check_Signature (Sec_DT, Must_Be_Primary_Or_Secondary_DT)); + (Check_Signature (Sec_DT, Must_Be_Secondary_DT)); - Offset_To_Top.all := Offset_Value; + if Is_Static then + Offset_To_Top.all := Offset_Value; + else + Offset_To_Top.all := SSE.Storage_Offset'Last; + end if; -- 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 @@ -1284,7 +1334,14 @@ package body Ada.Tags is if Iface_Table /= null then for Id in 1 .. Iface_Table.Nb_Ifaces loop if Iface_Table.Table (Id).Iface_Tag = Interface_T then - Iface_Table.Table (Id).Offset := Offset_Value; + Iface_Table.Table (Id).Static_Offset_To_Top := Is_Static; + + if Is_Static then + Iface_Table.Table (Id).Offset_To_Top_Value := Offset_Value; + else + Iface_Table.Table (Id).Offset_To_Top_Func := Offset_Func; + end if; + return; end if; end loop; @@ -1307,6 +1364,22 @@ package body Ada.Tags is OSD_Ptr.all := Value; end Set_OSD; + ------------------------------------ + -- Set_Predefined_Prim_Op_Address -- + ------------------------------------ + + procedure Set_Predefined_Prim_Op_Address + (T : Tag; + Position : Positive; + Value : System.Address) + is + Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size); + begin + pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); + pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count); + Prim_Ops_DT.Prims_Ptr (Position) := Value; + end Set_Predefined_Prim_Op_Address; + ------------------------- -- Set_Prim_Op_Address -- ------------------------- @@ -1318,7 +1391,7 @@ package body Ada.Tags is is begin pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT)); - pragma Assert (Check_Index (T, Position)); + pragma Assert (Position <= Get_Num_Prim_Ops (T)); T.Prims_Ptr (Position) := Value; end Set_Prim_Op_Address; @@ -1331,12 +1404,10 @@ package body Ada.Tags is Position : Positive; Value : Prim_Op_Kind) is - Index : constant Integer := Position - Default_Prim_Op_Count; begin pragma Assert (Check_Signature (T, Must_Be_Primary_DT)); - pragma Assert (Check_Index (T, Position)); - pragma Assert (Index > 0); - SSD (T).SSD_Table (Index).Kind := Value; + pragma Assert (Position <= Get_Num_Prim_Ops (T)); + SSD (T).SSD_Table (Position).Kind := Value; end Set_Prim_Op_Kind; ------------------- @@ -1359,6 +1430,19 @@ package body Ada.Tags is TSD (T).Remotely_Callable := Value; end Set_Remotely_Callable; + ------------------- + -- Set_Signature -- + ------------------- + + procedure Set_Signature (T : Tag; Value : Signature_Kind) is + Signature : constant System.Address := To_Address (T) - K_Signature; + Sig_Ptr : constant Signature_Values_Ptr := + To_Signature_Values_Ptr (Signature); + begin + Sig_Ptr.all (1) := Valid_Signature; + Sig_Ptr.all (2) := Value; + end Set_Signature; + ------------- -- Set_SSD -- ------------- @@ -1426,4 +1510,28 @@ package body Ada.Tags is return To_Type_Specific_Data_Ptr (TSD_Ptr.all); end TSD; + ------------------------ + -- Wide_Expanded_Name -- + ------------------------ + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Encoding method for source, as exported by binder + + function Wide_Expanded_Name (T : Tag) return Wide_String is + begin + return String_To_Wide_String + (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding)); + end Wide_Expanded_Name; + + ----------------------------- + -- Wide_Wide_Expanded_Name -- + ----------------------------- + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is + begin + return String_To_Wide_Wide_String + (Expanded_Name (T), Get_WC_Encoding_Method (WC_Encoding)); + end Wide_Wide_Expanded_Name; + end Ada.Tags; |