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

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;