rtsfind.ads, [...]: Complete support for Ada 2005 interfaces.

2005-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* rtsfind.ads, exp_util.adb, exp_util.ads, exp_disp.adb, exp_disp.ads,
	exp_ch7.adb, sem_ch9.adb, snames.adb, snames.ads,
	exp_ch9.adb, exp_ch9.ads, exp_ch6.adb, exp_ch3.adb, exp_ch3.ads,
	einfo.ads, einfo.adb: Complete support for Ada 2005 interfaces.

	* a-tags.ads, a-tags.adb: Major rewrite and additions to implement
	properly new Ada 2005 interfaces (AI-345) and add run-time checks (via
	assertions).

	* exp_dbug.ads, exp_dbug.adb (Get_Secondary_DT_External_Name): New
	subprogram that generates the external name associated with a
	secondary dispatch table.
	(Get_Secondary_DT_External_Name): New subprogram that generates the
	external name associated with a secondary dispatch table.

From-SVN: r106965

gcc/ada/a-tags.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -39,43 +39,64 @@ pragma Elaborate_All (System.HTable);
 
 package body Ada.Tags is
 
---  Structure of the GNAT Dispatch Table
+--  Structure of the GNAT Primary Dispatch Table
 
 --           +-----------------------+
+--           |       Signature       |
+--           +-----------------------+
 --           |     Offset_To_Top     |
 --           +-----------------------+
---           | Typeinfo_Ptr/TSD_Ptr  |----> Type Specific Data
+--           | Typeinfo_Ptr/TSD_Ptr  | ---> Type Specific Data
 --  Tag ---> +-----------------------+      +-------------------+
 --           |        table of       |      | inheritance depth |
 --           :     primitive ops     :      +-------------------+
---           |        pointers       |      |   expanded name   |
+--           |        pointers       |      |   access level    |
 --           +-----------------------+      +-------------------+
---                                          |   external tag    |
---                                          +-------------------+
---                                          |   Hash table link |
+--                                          |   expanded name   |
 --                                          +-------------------+
---                                          | Remotely Callable |
---                                          +-------------------+
---                                          | Rec Ctrler offset |
+--                                          |   external tag    |
 --                                          +-------------------+
---                                          |  Num_Interfaces   |
+--                                          |   hash table link |
 --                                          +-------------------+
---                                          | table of          |
---                                          :   ancestor        :
---                                          |      tags         |
+--                                          | remotely callable |
 --                                          +-------------------+
---                                          | table of          |
---                                          :   interface       :
---                                          |      tags         |
+--                                          | rec ctrler offset |
 --                                          +-------------------+
---                                          | table of          |
---                                          :   primitive op    :
---                                          |     kinds         |
+--                                          |   num prim ops    |
 --                                          +-------------------+
---                                          | table of          |
---                                          :   entry           :
---                                          |     indices       |
+--                                          |  num interfaces   |
 --                                          +-------------------+
+--           Select Specific Data      <--- |     SSD_Ptr       |
+--           +-----------------------+      +-------------------+
+--           | table of primitive    |      | table of          |
+--           :    operation          :      :    ancestor       :
+--           |       kinds           |      |       tags        |
+--           +-----------------------+      +-------------------+
+--           | table of              |      | table of          |
+--           :    entry              :      :    interface      :
+--           |       indices         |      |       tags        |
+--           +-----------------------+      +-------------------+
+
+--  Structure of the GNAT Secondary Dispatch Table
+
+--           +-----------------------+
+--           |       Signature       |
+--           +-----------------------+
+--           |     Offset_To_Top     |
+--           +-----------------------+
+--           |        OSD_Ptr        |---> Object Specific Data
+--  Tag ---> +-----------------------+      +---------------+
+--           |        table of       |      | num prim ops  |
+--           :      primitive op     :      +---------------+
+--           |     thunk pointers    |      | table of      |
+--           +-----------------------+      +   primitive   |
+--                                          |    op offsets |
+--                                          +---------------+
+
+   Offset_To_Signature : constant SSE.Storage_Count :=
+                           DT_Typeinfo_Ptr_Size
+                             + DT_Offset_To_Top_Size
+                             + DT_Signature_Size;
 
    subtype Cstring is String (Positive);
    type Cstring_Ptr is access all Cstring;
@@ -87,13 +108,39 @@ package body Ada.Tags is
    pragma Suppress_Initialization (Tag_Table);
    pragma Suppress (Index_Check, On => Tag_Table);
 
-   type Prim_Op_Kind_Table is array (Natural range <>) of Prim_Op_Kind;
-   pragma Suppress_Initialization (Prim_Op_Kind_Table);
-   pragma Suppress (Index_Check, On => Prim_Op_Kind_Table);
+   --  Object specific data types
+
+   type Object_Specific_Data_Array is array (Positive range <>) of Positive;
+
+   type Object_Specific_Data (Nb_Prim : Positive) is record
+      Num_Prim_Ops : Natural;
+      --  Number of primitive operations of the dispatch table. This field is
+      --  used by the run-time check routines that are activated when the
+      --  run-time is compiled with assertions enabled.
+
+      OSD_Table : Object_Specific_Data_Array (1 .. Nb_Prim);
+      --  Table used in secondary DT to reference their counterpart in the
+      --  select specific data (in the TSD of the primary DT). This construct
+      --  is used in the handling of dispatching triggers in select statements.
+      --  Nb_Prim is the number of non-predefined primitive operations.
+   end record;
+
+   --  Select specific data types
+
+   type Select_Specific_Data_Element is record
+      Index : Positive;
+      Kind  : Prim_Op_Kind;
+   end record;
+
+   type Select_Specific_Data_Array is
+     array (Positive range <>) of Select_Specific_Data_Element;
+
+   type Select_Specific_Data (Nb_Prim : Positive) is record
+      SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim);
+      --  NOTE: Nb_Prim is the number of non-predefined primitive operations
+   end record;
 
-   type Entry_Index_Table is array (Natural range <>) of Positive;
-   pragma Suppress_Initialization (Entry_Index_Table);
-   pragma Suppress (Index_Check, On => Entry_Index_Table);
+   --  Type specific data types
 
    type Type_Specific_Data is record
       Idepth : Natural;
@@ -124,11 +171,22 @@ package body Ada.Tags is
       --  Controller Offset: Used to give support to tagged controlled objects
       --  (see Get_Deep_Controller at s-finimp)
 
+      Num_Prim_Ops : Natural;
+      --  Number of primitive operations of the dispatch table. This field is
+      --  used for additional run-time checks when the run-time is compiled
+      --  with assertions enabled.
+
       Num_Interfaces : Natural;
       --  Number of abstract interface types implemented by the tagged type.
       --  The value Idepth+Num_Interfaces indicates the end of the second table
       --  stored in the Tags_Table component. It is used to implement the
-      --  membership test associated with interfaces (Ada 2005:AI-251)
+      --  membership test associated with interfaces (Ada 2005:AI-251).
+
+      SSD_Ptr : System.Address;
+      --  Pointer to a table of records used in dispatching selects. This
+      --  field has a meaningful value for all tagged types that implement
+      --  a limited, protected, synchronized or task interfaces and have
+      --  non-predefined primitive operations.
 
       Tags_Table : Tag_Table (0 .. 1);
       --  The size of the Tags_Table array actually depends on the tagged type
@@ -138,21 +196,9 @@ package body Ada.Tags is
       --  purpose we are using the same mechanism as for the Prims_Ptr array in
       --  the Dispatch_Table record. See comments below on Prims_Ptr for
       --  further details.
-
-      POK_Table       : Prim_Op_Kind_Table (1 .. 1);
-      Ent_Index_Table : Entry_Index_Table  (1 .. 1);
-      --  Two auxiliary tables used for dispatching in asynchronous,
-      --  conditional and timed selects. Their size depends on the number
-      --  of primitive operations. Indexing in these two tables is performed
-      --  by subtracting the number of predefined primitive operations from
-      --  the given index value. POK_Table contains the callable entity kinds
-      --  of all non-predefined primitive operations. Ent_Index_Table contains
-      --  the entry index of primitive entry wrappers.
    end record;
 
    type Dispatch_Table is record
-      --  Offset_To_Top : Natural;
-      --  Typeinfo_Ptr  : System.Address;
 
       --  According to the C++ ABI the components Offset_To_Top and
       --  Typeinfo_Ptr are stored just "before" the dispatch table (that is,
@@ -164,6 +210,9 @@ package body Ada.Tags is
       --  enough space for these additional components, and generates code that
       --  displaces the _Tag to point after these components.
 
+      --  Offset_To_Top : Natural;
+      --  Typeinfo_Ptr  : System.Address;
+
       Prims_Ptr : Address_Array (1 .. 1);
       --  The size of the Prims_Ptr array actually depends on the tagged type
       --  to which it applies. For each tagged type, the expander computes the
@@ -185,6 +234,20 @@ 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,
+       Must_Be_Primary_Or_Secondary_DT,
+       Must_Be_Interface,
+       Must_Be_Primary_Or_Interface);
+   --  Type of signature accepted by primitives in this package that are called
+   --  during the elaboration of tagged types. This type is used by the routine
+   --  Check_Signature that is called only when the run-time is compiled with
+   --  assertions enabled.
+
    ---------------------------------------------
    -- Unchecked Conversions for String Fields --
    ---------------------------------------------
@@ -199,6 +262,12 @@ package body Ada.Tags is
    -- 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
+
    type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
 
    function To_Storage_Offset_Ptr is
@@ -208,6 +277,30 @@ 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.
+
+   function Check_Size
+     (Old_T       : Tag;
+      New_T       : Tag;
+      Entry_Count : Natural) return Boolean;
+   --  Verify that Old_T and New_T have at least Entry_Count entries
+
+   function Get_Num_Prim_Ops (T : Tag) return Natural;
+   --  Retrieve the number of primitive operations in the dispatch table of T
+
+   function Is_Primary_DT (T : Tag) return Boolean;
+   pragma Inline_Always (Is_Primary_DT);
+   --  Given a tag returns True if it has the signature of a primary dispatch
+   --  table.  This is Inline_Always since it is called from other Inline_
+   --  Always subprograms where we want no out of line code to be generated.
+
    function Length (Str : Cstring_Ptr) return Natural;
    --  Length of string represented by the given pointer (treating the string
    --  as a C-style string, which is Nul terminated).
@@ -313,6 +406,93 @@ 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 --
+   ---------------------
+
+   function Check_Signature (T : Tag; Kind : Signature_Type) return Boolean is
+      Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
+                            To_Storage_Offset_Ptr (To_Address (T)
+                              - Offset_To_Signature);
+
+      Signature : constant Signature_Values :=
+                    To_Signature_Values (Offset_To_Top_Ptr.all);
+
+      Signature_Id : Signature_Kind;
+
+   begin
+      if Signature (1) /= Valid_Signature then
+         Signature_Id := Unknown;
+
+      elsif Signature (2) in Primary_DT .. Abstract_Interface then
+         Signature_Id := Signature (2);
+
+      else
+         Signature_Id := Unknown;
+      end if;
+
+      case Signature_Id is
+         when Primary_DT         =>
+            if Kind = Must_Be_Secondary_DT
+              or else Kind = Must_Be_Interface
+            then
+               return False;
+            end if;
+
+         when Secondary_DT       =>
+            if Kind = Must_Be_Primary_DT
+              or else Kind = Must_Be_Interface
+            then
+               return False;
+            end if;
+
+         when Abstract_Interface =>
+            if Kind = Must_Be_Primary_DT
+              or else Kind = Must_Be_Secondary_DT
+              or else Kind = Must_Be_Primary_Or_Secondary_DT
+            then
+               return False;
+            end if;
+
+         when others =>
+            return False;
+
+      end case;
+
+      return True;
+   end Check_Signature;
+
+   ----------------
+   -- Check_Size --
+   ----------------
+
+   function Check_Size
+     (Old_T       : Tag;
+      New_T       : Tag;
+      Entry_Count : Natural) return Boolean
+   is
+      Max_Entries_Old : constant Natural := Get_Num_Prim_Ops (Old_T);
+      Max_Entries_New : constant Natural := Get_Num_Prim_Ops (New_T);
+
+   begin
+      return Entry_Count <= Max_Entries_Old
+        and then Entry_Count <= Max_Entries_New;
+   end Check_Size;
+
    -------------------
    -- CW_Membership --
    -------------------
@@ -334,8 +514,11 @@ package body Ada.Tags is
    --     = Typ'tag
 
    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
-      Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
+      Pos : Integer;
    begin
+      pragma Assert (Check_Signature (Obj_Tag, Must_Be_Primary_DT));
+      pragma Assert (Check_Signature (Typ_Tag, Must_Be_Primary_DT));
+      Pos := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
       return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag;
    end CW_Membership;
 
@@ -353,23 +536,34 @@ package body Ada.Tags is
    --  Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
    --  that are contained in the dispatch table referenced by Obj'Tag.
 
-   function IW_Membership
-     (This : System.Address;
-      T    : Tag) return Boolean
-   is
+   function IW_Membership (This : System.Address; T : Tag) return Boolean is
       Curr_DT  : constant Tag := To_Tag_Ptr (This).all;
-      Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT);
-      Obj_DT   : constant Tag := To_Tag_Ptr (Obj_Base).all;
-
-      Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT);
-      Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
       Id       : Natural;
+      Last_Id  : Natural;
+      Obj_Base : System.Address;
+      Obj_DT   : Tag;
+      Obj_TSD  : Type_Specific_Data_Ptr;
 
    begin
+      pragma Assert
+        (Check_Signature (Curr_DT, Must_Be_Primary_Or_Secondary_DT));
+      pragma Assert
+        (Check_Signature (T, Must_Be_Primary_Or_Interface));
+
+      Obj_Base := This - Offset_To_Top (Curr_DT);
+      Obj_DT   := To_Tag_Ptr (Obj_Base).all;
+
+      pragma Assert
+        (Check_Signature (Curr_DT, Must_Be_Primary_DT));
+
+      Obj_TSD := TSD (Obj_DT);
+      Last_Id := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
+
       if Obj_TSD.Num_Interfaces > 0 then
 
          --  Traverse the ancestor tags table plus the interface tags table.
-         --  The former part is required to give support to:
+         --  The former part is required for:
+
          --     Iface_CW in Typ'Class
 
          Id := 0;
@@ -391,9 +585,13 @@ package body Ada.Tags is
    --------------------
 
    function Descendant_Tag (External : String; Ancestor : Tag) return Tag is
-      Int_Tag : constant Tag := Internal_Tag (External);
+      Int_Tag : Tag;
 
    begin
+      pragma Assert (Check_Signature (Ancestor, Must_Be_Primary_DT));
+      Int_Tag := Internal_Tag (External);
+      pragma Assert (Check_Signature (Int_Tag, Must_Be_Primary_DT));
+
       if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then
          raise Tag_Error;
       end if;
@@ -413,6 +611,7 @@ package body Ada.Tags is
          raise Tag_Error;
       end if;
 
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
       Result := TSD (T).Expanded_Name;
       return Result (1 .. Length (Result));
    end Expanded_Name;
@@ -423,11 +622,13 @@ package body Ada.Tags is
 
    function External_Tag (T : Tag) return String is
       Result : Cstring_Ptr;
+
    begin
       if T = No_Tag then
          raise Tag_Error;
       end if;
 
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
       Result := TSD (T).External_Tag;
 
       return Result (1 .. Length (Result));
@@ -439,6 +640,7 @@ package body Ada.Tags is
 
    function Get_Access_Level (T : Tag) return Natural is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
       return TSD (T).Access_Level;
    end Get_Access_Level;
 
@@ -446,11 +648,12 @@ package body Ada.Tags is
    -- Get_Entry_Index --
    ---------------------
 
-   function Get_Entry_Index
-     (T        : Tag;
-      Position : Positive) return Positive is
+   function Get_Entry_Index (T : Tag; Position : Positive) return Positive is
+      Index : constant Integer := Position - Default_Prim_Op_Count;
    begin
-      return TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count);
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+      pragma Assert (Index > 0);
+      return SSD (T).SSD_Table (Index).Index;
    end Get_Entry_Index;
 
    ----------------------
@@ -459,17 +662,36 @@ package body Ada.Tags is
 
    function Get_External_Tag (T : Tag) return System.Address is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
       return To_Address (TSD (T).External_Tag);
    end Get_External_Tag;
 
+   ----------------------
+   -- Get_Num_Prim_Ops --
+   ----------------------
+
+   function Get_Num_Prim_Ops (T : Tag) return Natural is
+   begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
+
+      if Is_Primary_DT (T) then
+         return TSD (T).Num_Prim_Ops;
+      else
+         return OSD (Interface_Tag (T)).Num_Prim_Ops;
+      end if;
+   end Get_Num_Prim_Ops;
+
    -------------------------
    -- Get_Prim_Op_Address --
    -------------------------
 
    function Get_Prim_Op_Address
      (T        : Tag;
-      Position : Positive) return System.Address is
+      Position : Positive) return System.Address
+   is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
+      pragma Assert (Check_Index (T, Position));
       return T.Prims_Ptr (Position);
    end Get_Prim_Op_Address;
 
@@ -479,17 +701,37 @@ package body Ada.Tags is
 
    function Get_Prim_Op_Kind
      (T        : Tag;
-      Position : Positive) return Prim_Op_Kind is
+      Position : Positive) return Prim_Op_Kind
+   is
+      Index : constant Integer := Position - Default_Prim_Op_Count;
    begin
-      return TSD (T).POK_Table (Position - Default_Prim_Op_Count);
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+      pragma Assert (Index > 0);
+      return SSD (T).SSD_Table (Index).Kind;
    end Get_Prim_Op_Kind;
 
+   ----------------------
+   -- Get_Offset_Index --
+   ----------------------
+
+   function Get_Offset_Index
+     (T        : Interface_Tag;
+      Position : Positive) return Positive
+   is
+      Index : constant Integer := Position - Default_Prim_Op_Count;
+   begin
+      pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
+      pragma Assert (Index > 0);
+      return OSD (T).OSD_Table (Index);
+   end Get_Offset_Index;
+
    -------------------
    -- Get_RC_Offset --
    -------------------
 
    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
       return TSD (T).RC_Offset;
    end Get_RC_Offset;
 
@@ -499,6 +741,7 @@ package body Ada.Tags is
 
    function Get_Remotely_Callable (T : Tag) return Boolean is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
       return TSD (T).Remotely_Callable;
    end Get_Remotely_Callable;
 
@@ -506,12 +749,12 @@ package body Ada.Tags is
    -- Inherit_DT --
    ----------------
 
-   procedure Inherit_DT
-    (Old_T       : Tag;
-     New_T       : Tag;
-     Entry_Count : Natural)
-   is
+   procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
    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));
+      pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
+
       if Old_T /= null then
          New_T.Prims_Ptr (1 .. Entry_Count) :=
            Old_T.Prims_Ptr (1 .. Entry_Count);
@@ -523,17 +766,22 @@ package body Ada.Tags is
    -----------------
 
    procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag) is
-      New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag);
+      New_TSD_Ptr : Type_Specific_Data_Ptr;
       Old_TSD_Ptr : Type_Specific_Data_Ptr;
 
    begin
+      pragma Assert (Check_Signature (New_Tag, Must_Be_Primary_Or_Interface));
+      New_TSD_Ptr := TSD (New_Tag);
+
       if Old_Tag /= null then
+         pragma Assert
+           (Check_Signature (Old_Tag, Must_Be_Primary_Or_Interface));
          Old_TSD_Ptr := TSD (Old_Tag);
          New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1;
          New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces;
 
          --  Copy the "table of ancestor tags" plus the "table of interfaces"
-         --  of the parent
+         --  of the parent.
 
          New_TSD_Ptr.Tags_Table
            (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
@@ -557,7 +805,7 @@ package body Ada.Tags is
 
    begin
       --  Make a copy of the string representing the external tag with
-      --  a null at the end
+      --  a null at the end.
 
       Ext_Copy (External'Range) := External;
       Ext_Copy (Ext_Copy'Last) := ASCII.NUL;
@@ -567,6 +815,7 @@ package body Ada.Tags is
          declare
             Msg1 : constant String := "unknown tagged type: ";
             Msg2 : String (1 .. Msg1'Length + External'Length);
+
          begin
             Msg2 (1 .. Msg1'Length) := Msg1;
             Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) :=
@@ -591,6 +840,20 @@ package body Ada.Tags is
         and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level;
    end Is_Descendant_At_Same_Level;
 
+   -------------------
+   -- Is_Primary_DT --
+   -------------------
+
+   function Is_Primary_DT (T : Tag) return Boolean is
+      Offset_To_Top_Ptr : constant Storage_Offset_Ptr :=
+                            To_Storage_Offset_Ptr (To_Address (T)
+                              - Offset_To_Signature);
+      Signature         : constant Signature_Values :=
+                            To_Signature_Values (Offset_To_Top_Ptr.all);
+   begin
+      return Signature (2) = Primary_DT;
+   end Is_Primary_DT;
+
    ------------
    -- Length --
    ------------
@@ -617,32 +880,45 @@ package body Ada.Tags is
                             To_Storage_Offset_Ptr (To_Address (T)
                               - DT_Typeinfo_Ptr_Size
                               - DT_Offset_To_Top_Size);
+
    begin
       return Offset_To_Top_Ptr.all;
    end Offset_To_Top;
 
+   ---------
+   -- OSD --
+   ---------
+
+   function OSD
+     (T : Interface_Tag) return Object_Specific_Data_Ptr
+   is
+      OSD_Ptr : Addr_Ptr;
+
+   begin
+      OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      return To_Object_Specific_Data_Ptr (OSD_Ptr.all);
+   end OSD;
+
    -----------------
    -- Parent_Size --
    -----------------
 
-   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
-
    function Parent_Size
      (Obj : System.Address;
       T   : Tag) return SSE.Storage_Count
    is
-      Parent_Tag : constant Tag := TSD (T).Tags_Table (1);
+      Parent_Tag : Tag;
       --  The tag of the parent type through the dispatch table
 
-      F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
+      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
+      --  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));
+
       --  Here we compute the size of the _parent field of the object
 
       return SSE.Storage_Count (F.all (Obj));
@@ -658,6 +934,8 @@ package body Ada.Tags is
          raise Tag_Error;
       end if;
 
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+
       --  The Parent_Tag of a root-level tagged type is defined to be No_Tag.
       --  The first entry in the Ancestors_Tags array will be null for such
       --  a type, but it's better to be explicit about returning No_Tag in
@@ -674,13 +952,16 @@ package body Ada.Tags is
    -- Register_Interface_Tag --
    ----------------------------
 
-   procedure Register_Interface_Tag
-    (T           : Tag;
-     Interface_T : Tag)
-   is
-      New_T_TSD : constant Type_Specific_Data_Ptr := TSD (T);
+   procedure Register_Interface_Tag (T : Tag; Interface_T : Tag) is
+      New_T_TSD : Type_Specific_Data_Ptr;
       Index     : Natural;
+
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+      pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
+
+      New_T_TSD := TSD (T);
+
       --  Check if the interface is already registered
 
       if New_T_TSD.Num_Interfaces > 0 then
@@ -688,6 +969,7 @@ package body Ada.Tags is
             Id      : Natural          := New_T_TSD.Idepth + 1;
             Last_Id : constant Natural := New_T_TSD.Idepth
                                             + New_T_TSD.Num_Interfaces;
+
          begin
             loop
                if New_T_TSD.Tags_Table (Id) = Interface_T then
@@ -720,6 +1002,7 @@ package body Ada.Tags is
 
    procedure Set_Access_Level (T : Tag; Value : Natural) is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
       TSD (T).Access_Level := Value;
    end Set_Access_Level;
 
@@ -730,9 +1013,14 @@ package body Ada.Tags is
    procedure Set_Entry_Index
      (T        : Tag;
       Position : Positive;
-      Value    : Positive) is
+      Value    : Positive)
+   is
+      Index : constant Integer := Position - Default_Prim_Op_Count;
+
    begin
-      TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count) := Value;
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+      pragma Assert (Index > 0);
+      SSD (T).SSD_Table (Index).Index := Value;
    end Set_Entry_Index;
 
    -----------------------
@@ -741,6 +1029,8 @@ package body Ada.Tags is
 
    procedure Set_Expanded_Name (T : Tag; Value : System.Address) is
    begin
+      pragma Assert
+        (Check_Signature (T, Must_Be_Primary_Or_Interface));
       TSD (T).Expanded_Name := To_Cstring_Ptr (Value);
    end Set_Expanded_Name;
 
@@ -750,9 +1040,41 @@ package body Ada.Tags is
 
    procedure Set_External_Tag (T : Tag; Value : System.Address) is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
       TSD (T).External_Tag := To_Cstring_Ptr (Value);
    end Set_External_Tag;
 
+   ----------------------
+   -- Set_Num_Prim_Ops --
+   ----------------------
+
+   procedure Set_Num_Prim_Ops (T : Tag; Value : Natural) is
+   begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
+
+      if Is_Primary_DT (T) then
+         TSD (T).Num_Prim_Ops := Value;
+      else
+         OSD (Interface_Tag (T)).Num_Prim_Ops := Value;
+      end if;
+   end Set_Num_Prim_Ops;
+
+   ----------------------
+   -- Set_Offset_Index --
+   ----------------------
+
+   procedure Set_Offset_Index
+     (T        : Interface_Tag;
+      Position : Positive;
+      Value    : Positive)
+   is
+      Index : constant Integer := Position - Default_Prim_Op_Count;
+   begin
+      pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
+      pragma Assert (Index > 0);
+      OSD (T).OSD_Table (Index) := Value;
+   end Set_Offset_Index;
+
    -----------------------
    -- Set_Offset_To_Top --
    -----------------------
@@ -766,9 +1088,22 @@ package body Ada.Tags is
                               - DT_Typeinfo_Ptr_Size
                               - DT_Offset_To_Top_Size);
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
       Offset_To_Top_Ptr.all := Value;
    end Set_Offset_To_Top;
 
+   -------------
+   -- Set_OSD --
+   -------------
+
+   procedure Set_OSD (T : Interface_Tag; Value : System.Address) is
+      OSD_Ptr : Addr_Ptr;
+   begin
+      pragma Assert (Check_Signature (Tag (T), Must_Be_Secondary_DT));
+      OSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      OSD_Ptr.all := Value;
+   end Set_OSD;
+
    -------------------------
    -- Set_Prim_Op_Address --
    -------------------------
@@ -776,8 +1111,11 @@ package body Ada.Tags is
    procedure Set_Prim_Op_Address
      (T        : Tag;
       Position : Positive;
-      Value    : System.Address) is
+      Value    : System.Address)
+   is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
+      pragma Assert (Check_Index (T, Position));
       T.Prims_Ptr (Position) := Value;
    end Set_Prim_Op_Address;
 
@@ -788,9 +1126,13 @@ package body Ada.Tags is
    procedure Set_Prim_Op_Kind
      (T        : Tag;
       Position : Positive;
-      Value    : Prim_Op_Kind) is
+      Value    : Prim_Op_Kind)
+   is
+      Index : constant Integer := Position - Default_Prim_Op_Count;
    begin
-      TSD (T).POK_Table (Position - Default_Prim_Op_Count) := Value;
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+      pragma Assert (Index > 0);
+      SSD (T).SSD_Table (Index).Kind := Value;
    end Set_Prim_Op_Kind;
 
    -------------------
@@ -799,6 +1141,7 @@ package body Ada.Tags is
 
    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset) is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
       TSD (T).RC_Offset := Value;
    end Set_RC_Offset;
 
@@ -808,20 +1151,41 @@ package body Ada.Tags is
 
    procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
       TSD (T).Remotely_Callable := Value;
    end Set_Remotely_Callable;
 
    -------------
+   -- Set_SSD --
+   -------------
+
+   procedure Set_SSD (T : Tag; Value : System.Address) is
+   begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+      TSD (T).SSD_Ptr := Value;
+   end Set_SSD;
+
+   -------------
    -- Set_TSD --
    -------------
 
    procedure Set_TSD (T : Tag; Value : System.Address) is
-      TSD_Ptr : constant Addr_Ptr :=
-                  To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
+      TSD_Ptr : Addr_Ptr;
    begin
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
+      TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
       TSD_Ptr.all := Value;
    end Set_TSD;
 
+   ---------
+   -- SSD --
+   ---------
+
+   function SSD (T : Tag) return Select_Specific_Data_Ptr is
+   begin
+      return To_Select_Specific_Data_Ptr (TSD (T).SSD_Ptr);
+   end SSD;
+
    ------------------
    -- Typeinfo_Ptr --
    ------------------

gcc/ada/a-tags.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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 --
@@ -53,31 +53,38 @@ package Ada.Tags is
 
    function Internal_Tag (External : String) return Tag;
 
-   function Descendant_Tag (External : String; Ancestor : Tag) return Tag;
+   function Descendant_Tag
+     (External : String;
+      Ancestor : Tag) return Tag;
+   pragma Ada_05 (Descendant_Tag);
 
    function Is_Descendant_At_Same_Level
      (Descendant : Tag;
       Ancestor   : Tag) return Boolean;
+   pragma Ada_05 (Is_Descendant_At_Same_Level);
 
    function Parent_Tag (T : Tag) return Tag;
+   pragma Ada_05 (Parent_Tag);
 
    Tag_Error : exception;
 
 private
+   --  The following subprogram specifications are placed here instead of
+   --  the package body to see them from the frontend through rtsfind.
 
    ---------------------------------------------------------------
    -- Abstract Procedural Interface For The GNAT Dispatch Table --
    ---------------------------------------------------------------
 
    --  GNAT's Dispatch Table format is customizable in order to match the
-   --  format used in another language. GNAT supports programs that use
-   --  two different dispatch table formats at the same time: the native
-   --  format that supports Ada 95 tagged types and which is described in
-   --  Ada.Tags, and a foreign format for types that are imported from some
-   --  other language (typically C++) which is described in Interfaces.CPP.
-   --  The runtime information kept for each tagged type is separated into
-   --  two objects: the Dispatch Table and the Type Specific Data record.
-   --  These two objects are allocated statically using the constants:
+   --  format used in another language. GNAT supports programs that use two
+   --  different dispatch table formats at the same time: the native format
+   --  that supports Ada 95 tagged types and which is described in Ada.Tags,
+   --  and a foreign format for types that are imported from some other
+   --  language (typically C++) which is described in Interfaces.CPP. The
+   --  runtime information kept for each tagged type is separated into two
+   --  objects: the Dispatch Table and the Type Specific Data record. These
+   --  two objects are allocated statically using the constants:
 
    --      DT Size  = DT_Prologue_Size  + Nb_Prim * DT_Entry_Size
    --      TSD Size = TSD_Prologue_Size + (1 + Idepth)  * TSD_Entry_Size
@@ -85,9 +92,9 @@ private
    --  where Nb_prim is the number of primitive operations of the given
    --  type and Idepth its inheritance depth.
 
-   --  The compiler generates calls to the following SET routines to
-   --  initialize those structures and uses the GET functions to
-   --  retreive the information when needed
+   --  In order to set or retrieve information from the Dispatch Table or
+   --  the Type Specific Data record, GNAT generates calls to Set_XXX or
+   --  Get_XXX routines, where XXX is the name of the field of interest.
 
    type Dispatch_Table;
    type Tag is access all Dispatch_Table;
@@ -95,6 +102,19 @@ private
 
    No_Tag : constant Tag := null;
 
+   type Object_Specific_Data (Nb_Prim : Positive);
+   type Object_Specific_Data_Ptr is access all Object_Specific_Data;
+   --  Information associated with the secondary dispatch table of tagged-type
+   --  objects implementing abstract interfaces.
+
+   type Select_Specific_Data (Nb_Prim : Positive);
+   type Select_Specific_Data_Ptr is access all Select_Specific_Data;
+   --  A table used to store the primitive operation kind and entry index of
+   --  primitive subprograms of a type that implements a limited interface.
+   --  The Select Specific Data table resides in the Type Specific Data of a
+   --  type. This construct is used in the handling of dispatching triggers
+   --  in select statements.
+
    type Type_Specific_Data;
    type Type_Specific_Data_Ptr is access all Type_Specific_Data;
 
@@ -109,17 +129,16 @@ private
       POK_Protected_Function,
       POK_Protected_Procedure,
       POK_Task_Entry,
+      POK_Task_Function,
       POK_Task_Procedure);
 
-   --  Number of predefined primitive operations added by the Expander
-   --  for a tagged type. It is utilized for indexing in the two auxiliary
-   --  tables used for dispatching asynchronous, conditional and timed
-   --  selects. In order to be space efficien, indexing is performed by
-   --  subtracting this constant value from the provided position in the
-   --  auxiliary tables.
-   --  This value is mirrored from Exp_Disp.ads.
-
-   Default_Prim_Op_Count : constant Positive := 14;
+   Default_Prim_Op_Count : constant Positive := 15;
+   --  Number of predefined primitive operations added by the Expander for a
+   --  tagged type. It is utilized for indexing in the two auxiliary tables
+   --  used for dispatching asynchronous, conditional and timed selects. In
+   --  order to be space efficient, indexing is performed by subtracting this
+   --  constant value from the provided position in the auxiliary tables (must
+   --  match Exp_Disp.Default_Prim_Op_Count).
 
    package SSE renames System.Storage_Elements;
 
@@ -127,9 +146,7 @@ private
    --  Given the tag of an object and the tag associated to a type, return
    --  true if Obj is in Typ'Class.
 
-   function IW_Membership
-     (This : System.Address;
-      T    : Tag) return Boolean;
+   function IW_Membership (This : System.Address; T : Tag) return Boolean;
    --  Ada 2005 (AI-251): General routine that checks if a given object
    --  implements a tagged type. Its common usage is to check if Obj is in
    --  Iface'Class, but it is also used to check if a class-wide interface
@@ -147,22 +164,27 @@ private
    --  Given the tag associated with a type, returns the accessibility level
    --  of the type.
 
-   function Get_Entry_Index
-     (T        : Tag;
-      Position : Positive) return Positive;
+   function Get_Entry_Index (T : Tag; Position : Positive) return Positive;
    --  Return a primitive operation's entry index (if entry) given a dispatch
    --  table T and a position of a primitive operation in T.
 
    function Get_External_Tag (T : Tag) return System.Address;
    --  Retrieve the address of a null terminated string containing
-   --  the external name
+   --  the external name.
+
+   function Get_Offset_Index
+     (T        : Interface_Tag;
+      Position : Positive) return Positive;
+   --  Given a pointer to a secondary dispatch table (T) and a position of an
+   --  operation in the DT, retrieve the corresponding operation's position in
+   --  the primary dispatch table from the Offset Specific Data table of T.
 
    function Get_Prim_Op_Address
      (T        : Tag;
       Position : Positive) return System.Address;
    --  Given a pointer to a dispatch table (T) and a position in the DT
    --  this function returns the address of the virtual function stored
-   --  in it (used for dispatching calls)
+   --  in it (used for dispatching calls).
 
    function Get_Prim_Op_Kind
      (T        : Tag;
@@ -182,10 +204,7 @@ private
    function Get_Remotely_Callable (T : Tag) return Boolean;
    --  Return the value previously set by Set_Remotely_Callable
 
-   procedure Inherit_DT
-    (Old_T       : Tag;
-     New_T       : Tag;
-     Entry_Count : Natural);
+   procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural);
    --  Entry point used to initialize the DT of a type knowing the tag
    --  of the direct ancestor and the number of primitive ops that are
    --  inherited (Entry_Count).
@@ -193,21 +212,23 @@ private
    procedure Inherit_TSD (Old_Tag : Tag; New_Tag : Tag);
    --  Initialize the TSD of a type knowing the tag of the direct ancestor
 
+   function OSD (T : Interface_Tag) return Object_Specific_Data_Ptr;
+   --  Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
+   --  retrieve the address of the record containing the Objet Specific
+   --  Data table.
+
    function Parent_Size
      (Obj : System.Address;
       T   : Tag) return SSE.Storage_Count;
-   --  Computes the size the ancestor part of a tagged extension object
-   --  whose address is 'obj' by calling the indirectly _size function of
-   --  the ancestor. The ancestor is the parent of the type represented by
-   --  tag T. This function assumes that _size is always in slot 1 of
-   --  the dispatch table.
+   --  Computes the size the ancestor part of a tagged extension object whose
+   --  address is 'obj' by calling indirectly the ancestor _size function. The
+   --  ancestor is the parent of the type represented by tag T. This function
+   --  assumes that _size is always in slot one of the dispatch table.
 
    pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
    --  This procedure is used in s-finimp and is thus exported manually
 
-   procedure Register_Interface_Tag
-    (T           : Tag;
-     Interface_T : Tag);
+   procedure Register_Interface_Tag (T : Tag; Interface_T : Tag);
    --  Ada 2005 (AI-251): Used to initialize the table of interfaces
    --  implemented by a type. Required to give support to IW_Membership.
 
@@ -215,13 +236,21 @@ private
    --  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);
+   procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
    --  Set the entry index of a primitive operation in T's TSD table indexed
    --  by Position.
 
+   procedure Set_Num_Prim_Ops (T : Tag; Value : Natural);
+   --  Set the number of primitive operations in the dispatch table of T. This
+   --  is used for debugging purposes.
+
+   procedure Set_Offset_Index
+     (T        : Interface_Tag;
+      Position : Positive;
+      Value    : Positive);
+   --  Set the offset value of a primitive operation in a secondary dispatch
+   --  table denoted by T, indexed by Position.
+
    procedure Set_Offset_To_Top
      (T     : Tag;
       Value : System.Storage_Elements.Storage_Offset);
@@ -230,6 +259,10 @@ private
    --  is always 0; in secondary dispatch tables this is the offset to the base
    --  of the enclosing type.
 
+   procedure Set_OSD (T : Interface_Tag; Value : System.Address);
+   --  Given a pointer T to a secondary dispatch table, store the pointer to
+   --  the record containing the Object Specific Data generated by GNAT.
+
    procedure Set_Prim_Op_Address
      (T        : Tag;
       Position : Positive;
@@ -245,6 +278,10 @@ private
    --  Set the kind of a primitive operation in T's TSD table indexed by
    --  Position.
 
+   procedure Set_SSD (T : Tag; Value : System.Address);
+   --  Given a pointer T to a dispatch Table, stores the pointer to the record
+   --  containing the Select Specific Data generated by GNAT.
+
    procedure Set_TSD (T : Tag; Value : System.Address);
    --  Given a pointer T to a dispatch Table, stores the address of the record
    --  containing the Type Specific Data generated by GNAT.
@@ -269,15 +306,24 @@ private
    --  Set to true if the type has been declared in a context described
    --  in E.4 (18).
 
+   function SSD (T : Tag) return Select_Specific_Data_Ptr;
+   --  Given a pointer T to a dispatch Table, retrieves the address of the
+   --  record containing the Select Specific Data in T's TSD.
+
    function TSD (T : Tag) return Type_Specific_Data_Ptr;
-   --  Given a pointer T to a dispatch Table, retreives the address of the
-   --  record containing the Type Specific Data generated by GNAT
+   --  Given a pointer T to a dispatch Table, retrieves the address of the
+   --  record containing the Type Specific Data generated by GNAT.
 
    DT_Prologue_Size : constant SSE.Storage_Count :=
                         SSE.Storage_Count
-                          (2 * (Standard'Address_Size / System.Storage_Unit));
+                          (3 * (Standard'Address_Size / System.Storage_Unit));
    --  Size of the first part of the dispatch table
 
+   DT_Signature_Size : constant SSE.Storage_Count :=
+                         SSE.Storage_Count
+                           (Standard'Address_Size / System.Storage_Unit);
+   --  Size of the Signature field of the dispatch table
+
    DT_Offset_To_Top_Size : constant SSE.Storage_Count :=
                             SSE.Storage_Count
                               (Standard'Address_Size / System.Storage_Unit);
@@ -295,7 +341,7 @@ private
 
    TSD_Prologue_Size : constant SSE.Storage_Count :=
                          SSE.Storage_Count
-                           (8 * (Standard'Address_Size / System.Storage_Unit));
+                          (10 * (Standard'Address_Size / System.Storage_Unit));
    --  Size of the first part of the type specific data
 
    TSD_Entry_Size : constant SSE.Storage_Count :=
@@ -308,22 +354,57 @@ private
    --  of this type are declared with a dummy size of 1, the actual size
    --  depending on the number of primitive operations.
 
-   --  Unchecked Conversions for Tag and TSD
+   type Signature_Kind is
+      (Unknown,
+       Valid_Signature,
+       Primary_DT,
+       Secondary_DT,
+       Abstract_Interface);
+   for Signature_Kind'Size use 8;
+   --  Kind of signature found in the header of the dispatch table. These
+   --  signatures are generated by the frontend and are used by the Check_XXX
+   --  routines to ensure that the kind of dispatch table managed by each of
+   --  the routines in this package is correct. This additional check is only
+   --  performed with this run-time package is compiled with assertions enabled
+
+   --  The signature is a sequence of two bytes. The first byte must have the
+   --  value Valid_Signature, and the second byte must have a value in the
+   --  range Primary_DT .. Abstract_Interface. The Unknown value is used by
+   --  the Check_XXX routines to indicate that the signature is wrong.
+
+   --  Unchecked Conversions
+
+   type Addr_Ptr is access System.Address;
+   type Tag_Ptr  is access Tag;
+
+   type Signature_Values is
+      array (1 .. DT_Signature_Size) of Signature_Kind;
+   --  Type used to see the signature as a sequence of Signature_Kind values
+
+   function To_Addr_Ptr is
+      new Unchecked_Conversion (System.Address, Addr_Ptr);
 
    function To_Type_Specific_Data_Ptr is
      new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
 
    function To_Address is
-     new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
+     new Unchecked_Conversion (Interface_Tag, System.Address);
 
    function To_Address is
      new Unchecked_Conversion (Tag, System.Address);
 
-   type Addr_Ptr is access System.Address;
-   type Tag_Ptr  is access Tag;
+   function To_Address is
+     new Unchecked_Conversion (Type_Specific_Data_Ptr, System.Address);
 
-   function To_Addr_Ptr is
-      new Unchecked_Conversion (System.Address, Addr_Ptr);
+   function To_Object_Specific_Data_Ptr is
+     new Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
+
+   function To_Select_Specific_Data_Ptr is
+     new Unchecked_Conversion (System.Address, Select_Specific_Data_Ptr);
+
+   function To_Signature_Values is
+     new Unchecked_Conversion (System.Storage_Elements.Storage_Offset,
+                               Signature_Values);
 
    function To_Tag_Ptr is
      new Unchecked_Conversion (System.Address, Tag_Ptr);
@@ -334,21 +415,32 @@ private
    pragma Inline_Always (CW_Membership);
    pragma Inline_Always (IW_Membership);
    pragma Inline_Always (Get_Access_Level);
+   pragma Inline_Always (Get_Entry_Index);
+   pragma Inline_Always (Get_Offset_Index);
    pragma Inline_Always (Get_Prim_Op_Address);
+   pragma Inline_Always (Get_Prim_Op_Kind);
    pragma Inline_Always (Get_RC_Offset);
    pragma Inline_Always (Get_Remotely_Callable);
    pragma Inline_Always (Inherit_DT);
    pragma Inline_Always (Inherit_TSD);
+   pragma Inline_Always (OSD);
    pragma Inline_Always (Register_Interface_Tag);
    pragma Inline_Always (Register_Tag);
    pragma Inline_Always (Set_Access_Level);
+   pragma Inline_Always (Set_Entry_Index);
    pragma Inline_Always (Set_Expanded_Name);
    pragma Inline_Always (Set_External_Tag);
+   pragma Inline_Always (Set_Num_Prim_Ops);
+   pragma Inline_Always (Set_Offset_Index);
    pragma Inline_Always (Set_Offset_To_Top);
    pragma Inline_Always (Set_Prim_Op_Address);
+   pragma Inline_Always (Set_Prim_Op_Kind);
    pragma Inline_Always (Set_RC_Offset);
    pragma Inline_Always (Set_Remotely_Callable);
+   pragma Inline_Always (Set_OSD);
+   pragma Inline_Always (Set_SSD);
    pragma Inline_Always (Set_TSD);
+   pragma Inline_Always (SSD);
    pragma Inline_Always (TSD);
 
 end Ada.Tags;

gcc/ada/einfo.adb

@@ -214,8 +214,10 @@ package body Einfo is
    --    Abstract_Interfaces             Elist24
 
    --    Abstract_Interface_Alias        Node25
+   --    Current_Use_Clause              Node25
 
    --    Overridden_Operation            Node26
+   --    Package_Instantiation           Node26
 
    --    Wrapped_Entity                  Node27
 
@@ -388,7 +390,7 @@ package body Einfo is
    --    Has_Recursive_Call             Flag143
    --    Is_Unsigned_Type               Flag144
    --    Strict_Alignment               Flag145
-   --    Elaborate_All_Desirable        Flag146
+   --    (unused)                       Flag146
    --    Needs_Debug_Info               Flag147
    --    Suppress_Elaboration_Warnings  Flag148
    --    Is_Compilation_Unit            Flag149
@@ -444,12 +446,13 @@ package body Einfo is
    --    Is_Local_Anonymous_Access      Flag194
    --    Is_Primitive_Wrapper           Flag195
    --    Was_Hidden                     Flag196
+   --    Is_Limited_Interface           Flag197
+   --    Is_Protected_Interface         Flag198
+   --    Is_Synchronized_Interface      Flag199
+   --    Is_Task_Interface              Flag200
+
+   --    Has_Anon_Block_Suffix          Flag201
 
-   --    (unused)                       Flag197
-   --    (unused)                       Flag198
-   --    (unused)                       Flag199
-   --    (unused)                       Flag200
-   --    (unused)                       Flag201
    --    (unused)                       Flag202
    --    (unused)                       Flag203
    --    (unused)                       Flag204
@@ -698,6 +701,12 @@ package body Einfo is
       return Node22 (Id);
    end Corresponding_Remote_Type;
 
+   function Current_Use_Clause (Id : E) return E is
+   begin
+      pragma Assert (Ekind (Id) = E_Package);
+      return Node25 (Id);
+   end Current_Use_Clause;
+
    function Current_Value (Id : E) return N is
    begin
       pragma Assert (Ekind (Id) in Object_Kind);
@@ -839,11 +848,6 @@ package body Einfo is
       return Node16 (Id);
    end DTC_Entity;
 
-   function Elaborate_All_Desirable (Id : E) return B is
-   begin
-      return Flag146 (Id);
-   end Elaborate_All_Desirable;
-
    function Elaboration_Entity (Id : E) return E is
    begin
       pragma Assert
@@ -1073,6 +1077,11 @@ package body Einfo is
       return Flag79 (Id);
    end Has_All_Calls_Remote;
 
+   function Has_Anon_Block_Suffix (Id : E) return B is
+   begin
+      return Flag201 (Id);
+   end Has_Anon_Block_Suffix;
+
    function Has_Atomic_Components (Id : E) return B is
    begin
       return Flag86 (Implementation_Base_Type (Id));
@@ -1667,6 +1676,12 @@ package body Einfo is
       return Flag106 (Id);
    end Is_Limited_Composite;
 
+   function Is_Limited_Interface (Id : E) return B is
+   begin
+      pragma Assert (Is_Interface (Id));
+      return Flag197 (Id);
+   end Is_Limited_Interface;
+
    function Is_Limited_Record (Id : E) return B is
    begin
       return Flag25 (Id);
@@ -1750,6 +1765,12 @@ package body Einfo is
       return Flag53 (Id);
    end Is_Private_Descendant;
 
+   function Is_Protected_Interface (Id : E) return B is
+   begin
+      pragma Assert (Is_Interface (Id));
+      return Flag198 (Id);
+   end Is_Protected_Interface;
+
    function Is_Public (Id : E) return B is
    begin
       pragma Assert (Nkind (Id) in N_Entity);
@@ -1792,6 +1813,12 @@ package body Einfo is
       return Flag28 (Id);
    end Is_Statically_Allocated;
 
+   function Is_Synchronized_Interface (Id : E) return B is
+   begin
+      pragma Assert (Is_Interface (Id));
+      return Flag199 (Id);
+   end Is_Synchronized_Interface;
+
    function Is_Tag (Id : E) return B is
    begin
       pragma Assert (Nkind (Id) in N_Entity);
@@ -1803,6 +1830,12 @@ package body Einfo is
       return Flag55 (Id);
    end Is_Tagged_Type;
 
+   function Is_Task_Interface (Id : E) return B is
+   begin
+      pragma Assert (Is_Interface (Id));
+      return Flag200 (Id);
+   end Is_Task_Interface;
+
    function Is_Thread_Body (Id : E) return B is
    begin
       return Flag77 (Id);
@@ -2016,7 +2049,8 @@ package body Einfo is
 
    function Obsolescent_Warning (Id : E) return N is
    begin
-      pragma Assert (Is_Subprogram (Id));
+      pragma Assert
+        (Is_Subprogram (Id) or else Is_Package_Or_Generic_Package (Id));
       return Node24 (Id);
    end Obsolescent_Warning;
 
@@ -2048,6 +2082,15 @@ package body Einfo is
       return Node26 (Id);
    end Overridden_Operation;
 
+   function Package_Instantiation (Id : E) return N is
+   begin
+      pragma Assert
+        (False
+           or else Ekind (Id) = E_Generic_Package
+           or else Ekind (Id) = E_Package);
+      return Node26 (Id);
+   end Package_Instantiation;
+
    function Packed_Array_Type (Id : E) return E is
    begin
       pragma Assert (Is_Array_Type (Id));
@@ -2744,7 +2787,13 @@ package body Einfo is
       Set_Node22 (Id, V);
    end Set_Corresponding_Remote_Type;
 
-   procedure Set_Current_Value (Id : E; V : E) is
+   procedure Set_Current_Use_Clause (Id : E; V : E) is
+   begin
+      pragma Assert (Ekind (Id) = E_Package);
+      Set_Node25 (Id, V);
+   end Set_Current_Use_Clause;
+
+   procedure Set_Current_Value (Id : E; V : N) is
    begin
       pragma Assert (Ekind (Id) in Object_Kind or else Ekind (Id) = E_Void);
       Set_Node9 (Id, V);
@@ -2888,11 +2937,6 @@ package body Einfo is
       Set_Node16 (Id, V);
    end Set_DTC_Entity;
 
-   procedure Set_Elaborate_All_Desirable (Id : E; V : B := True) is
-   begin
-      Set_Flag146 (Id, V);
-   end Set_Elaborate_All_Desirable;
-
    procedure Set_Elaboration_Entity (Id : E; V : E) is
    begin
       pragma Assert
@@ -3126,6 +3170,11 @@ package body Einfo is
       Set_Flag79 (Id, V);
    end Set_Has_All_Calls_Remote;
 
+   procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True) is
+   begin
+      Set_Flag201 (Id, V);
+   end Set_Has_Anon_Block_Suffix;
+
    procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
    begin
       pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id);
@@ -3754,6 +3803,12 @@ package body Einfo is
       Set_Flag106 (Id, V);
    end Set_Is_Limited_Composite;
 
+   procedure Set_Is_Limited_Interface (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Interface (Id));
+      Set_Flag197 (Id, V);
+   end Set_Is_Limited_Interface;
+
    procedure Set_Is_Limited_Record (Id : E; V : B := True) is
    begin
       Set_Flag25 (Id, V);
@@ -3838,6 +3893,12 @@ package body Einfo is
       Set_Flag53 (Id, V);
    end Set_Is_Private_Descendant;
 
+   procedure Set_Is_Protected_Interface (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Interface (Id));
+      Set_Flag198 (Id, V);
+   end Set_Is_Protected_Interface;
+
    procedure Set_Is_Public (Id : E; V : B := True) is
    begin
       pragma Assert (Nkind (Id) in N_Entity);
@@ -3886,6 +3947,12 @@ package body Einfo is
       Set_Flag28 (Id, V);
    end Set_Is_Statically_Allocated;
 
+   procedure Set_Is_Synchronized_Interface (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Interface (Id));
+      Set_Flag199 (Id, V);
+   end Set_Is_Synchronized_Interface;
+
    procedure Set_Is_Tag (Id : E; V : B := True) is
    begin
       pragma Assert (Nkind (Id) in N_Entity);
@@ -3902,6 +3969,12 @@ package body Einfo is
       Set_Flag77 (Id, V);
    end Set_Is_Thread_Body;
 
+   procedure Set_Is_Task_Interface (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Interface (Id));
+      Set_Flag200 (Id, V);
+   end Set_Is_Task_Interface;
+
    procedure Set_Is_True_Constant (Id : E; V : B := True) is
    begin
       Set_Flag163 (Id, V);
@@ -4108,7 +4181,8 @@ package body Einfo is
 
    procedure Set_Obsolescent_Warning (Id : E; V : N) is
    begin
-      pragma Assert (Is_Subprogram (Id));
+      pragma Assert
+        (Is_Subprogram (Id) or else Is_Package_Or_Generic_Package (Id));
       Set_Node24 (Id, V);
    end Set_Obsolescent_Warning;
 
@@ -4140,6 +4214,15 @@ package body Einfo is
       Set_Node26 (Id, V);
    end Set_Overridden_Operation;
 
+   procedure Set_Package_Instantiation (Id : E; V : N) is
+   begin
+      pragma Assert
+        (Ekind (Id) = E_Void
+           or else Ekind (Id) = E_Generic_Package
+           or else Ekind (Id) = E_Package);
+      Set_Node26 (Id, V);
+   end Set_Package_Instantiation;
+
    procedure Set_Packed_Array_Type (Id : E; V : E) is
    begin
       pragma Assert (Is_Array_Type (Id));
@@ -5693,17 +5776,17 @@ package body Einfo is
       end if;
    end Is_Limited_Type;
 
-   ----------------
-   -- Is_Package --
-   ----------------
+   -----------------------------------
+   -- Is_Package_Or_Generic_Package --
+   -----------------------------------
 
-   function Is_Package (Id : E) return B is
+   function Is_Package_Or_Generic_Package (Id : E) return B is
    begin
       return
         Ekind (Id) = E_Package
           or else
         Ekind (Id) = E_Generic_Package;
-   end Is_Package;
+   end Is_Package_Or_Generic_Package;
 
    --------------------------
    -- Is_Protected_Private --
@@ -6466,7 +6549,6 @@ package body Einfo is
       W ("Delay_Subprogram_Descriptors",  Flag50  (Id));
       W ("Depends_On_Private",            Flag14  (Id));
       W ("Discard_Names",                 Flag88  (Id));
-      W ("Elaborate_All_Desirable",       Flag146 (Id));
       W ("Elaboration_Entity_Required",   Flag174 (Id));
       W ("Entry_Accepted",                Flag152 (Id));
       W ("Finalize_Storage_Only",         Flag158 (Id));
@@ -6475,6 +6557,7 @@ package body Einfo is
       W ("Has_Aliased_Components",        Flag135 (Id));
       W ("Has_Alignment_Clause",          Flag46  (Id));
       W ("Has_All_Calls_Remote",          Flag79  (Id));
+      W ("Has_Anon_Block_Suffix",         Flag201 (Id));
       W ("Has_Atomic_Components",         Flag86  (Id));
       W ("Has_Biased_Representation",     Flag139 (Id));
       W ("Has_Completion",                Flag26  (Id));
@@ -6580,6 +6663,7 @@ package body Einfo is
       W ("Is_Known_Valid",                Flag37  (Id));
       W ("Is_Known_Valid",                Flag170 (Id));
       W ("Is_Limited_Composite",          Flag106 (Id));
+      W ("Is_Limited_Interface",          Flag197 (Id));
       W ("Is_Limited_Record",             Flag25  (Id));
       W ("Is_Machine_Code_Subprogram",    Flag137 (Id));
       W ("Is_Non_Static_Subtype",         Flag109 (Id));
@@ -6595,6 +6679,7 @@ package body Einfo is
       W ("Is_Primitive_Wrapper",          Flag195 (Id));
       W ("Is_Private_Composite",          Flag107 (Id));
       W ("Is_Private_Descendant",         Flag53  (Id));
+      W ("Is_Protected_Interface",        Flag198 (Id));
       W ("Is_Public",                     Flag10  (Id));
       W ("Is_Pure",                       Flag44  (Id));
       W ("Is_Pure_Unit_Access_Type",      Flag189 (Id));
@@ -6602,9 +6687,11 @@ package body Einfo is
       W ("Is_Remote_Types",               Flag61  (Id));
       W ("Is_Renaming_Of_Object",         Flag112 (Id));
       W ("Is_Shared_Passive",             Flag60  (Id));
+      W ("Is_Synchronized_Interface",     Flag199 (Id));
       W ("Is_Statically_Allocated",       Flag28  (Id));
       W ("Is_Tag",                        Flag78  (Id));
       W ("Is_Tagged_Type",                Flag55  (Id));
+      W ("Is_Task_Interface",             Flag200 (Id));
       W ("Is_Thread_Body",                Flag77  (Id));
       W ("Is_True_Constant",              Flag163 (Id));
       W ("Is_Unchecked_Union",            Flag117 (Id));
@@ -7526,7 +7613,9 @@ package body Einfo is
               E_Record_Subtype_With_Private              =>
             Write_Str ("Abstract_Interfaces");
 
-         when Subprogram_Kind                            =>
+         when Subprogram_Kind                            |
+              E_Package                                  |
+              E_Generic_Package                          =>
             Write_Str ("Obsolescent_Warning");
 
          when Task_Kind                                  =>
@@ -7548,6 +7637,9 @@ package body Einfo is
               E_Function                                 =>
             Write_Str ("Abstract_Interface_Alias");
 
+         when E_Package                                  =>
+            Write_Str ("Current_Use_Clause");
+
          when others                                     =>
             Write_Str ("Field25??");
       end case;
@@ -7560,6 +7652,10 @@ package body Einfo is
    procedure Write_Field26_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
+         when E_Generic_Package                          |
+              E_Package                                  =>
+            Write_Str ("Package_Instantiation");
+
          when E_Procedure                                |
               E_Function                                 =>
             Write_Str ("Overridden_Operation");

gcc/ada/einfo.ads

@@ -594,6 +594,11 @@ package Einfo is
 --      created at the same time as the discriminal, and used to replace
 --      occurrences of the discriminant within the type declaration.
 
+--    Current_Use_Clause (Node25)
+--      Present in packages. Indicates the use clause currently in scope
+--      that makes the package use_visible. Used to detect redundant use
+--      clauses for the same package.
+
 --    Current_Value (Node9)
 --       Present in E_Variable, E_Out_Parameter and E_In_Out_Parameter
 --       entities. Set non-Empty if the (constant) current value of the
@@ -801,13 +806,6 @@ package Einfo is
 --       Present in all entities. Contains a value of the enumeration type
 --       Entity_Kind declared in a subsequent section in this spec.
 
---    Elaborate_All_Desirable (Flag146)
---       Present in package and subprogram entities, and in generic package
---       and subprogram entities. Set if internal analysis of a client that
---       with's this unit determines that Elaborate_All is desirable, i.e.
---       that there is a possibility that Program_Error may be raised if
---       Elaborate_All conditions cannot be met.
-
 --    Elaboration_Entity (Node13)
 --       Present in generic and non-generic package and subprogram
 --       entities. This is a boolean entity associated with the unit that
@@ -1230,6 +1228,11 @@ package Einfo is
 --       be RCI entities, so the flag Is_Remote_Call_Interface will always
 --       be set if this flag is set.
 
+--    Has_Anon_Block_Suffix (Flag201)
+--       Present in all entities. Set if the entity is nested within one or
+--       more anonymous blocks and the Chars field contains a name with an
+--       anonymous block suffix (see Exp_Dbug for furthert details).
+
 --    Has_Atomic_Components (Flag86) [implementation base type only]
 --       Present in all types and objects. Set only for an array type or
 --       an array object if a valid pragma Atomic_Components applies to the
@@ -2106,6 +2109,10 @@ package Einfo is
 --       do not become visible until the immediate scope of the composite
 --       type itself (RM 7.3.1 (5)).
 
+--    Is_Limited_Interface (Flag197)
+--       Present in types that are interfaces. True if interface is declared
+--       limited, or is derived from limited interfaces.
+
 --    Is_Limited_Record (Flag25)
 --       Present in all entities. Set to true for record (sub)types if the
 --       record is declared to be limited. Note that this flag is not set
@@ -2159,8 +2166,8 @@ package Einfo is
 --       including generic formal parameters.
 
 --    Is_Obsolescent (Flag153)
---       Present in all entities. Set only for subprograms when a valid pragma
---       Obsolescent applies to the subprogram.
+--       Present in all entities. Set only for packages and subprograms to
+--       which a valid pragma Obsolescent applies.
 
 --    Is_Optional_Parameter (Flag134)
 --       Present in parameter entities. Set if the parameter is specified as
@@ -2175,7 +2182,7 @@ package Einfo is
 --       Present in subprograms. Set if the subprogram is a primitive
 --       operation of a derived type, that overrides an inherited operation.
 
---    Is_Package (synthesized)
+--    Is_Package_Or_Generic_Package (synthesized)
 --       Applies to all entities. True for packages and generic packages.
 --       False for all other entities.
 
@@ -2264,6 +2271,10 @@ package Einfo is
 --       Applies to all entities, true for private types and subtypes,
 --       as well as for record with private types as subtypes
 
+--    Is_Protected_Interface (Flag198)
+--       Present in types that are interfaces. True if interface is declared
+--       protected, or is derived from protected interfaces.
+
 --    Is_Protected_Type (synthesized)
 --       Applies to all entities, true for protected types and subtypes
 
@@ -2358,6 +2369,10 @@ package Einfo is
 --       or a string slice type, or an array type with one dimension and a
 --       component type that is a character type.
 
+--    Is_Synchronized_Interface (Flag199)
+--       Present_types that are interfaces. True is interface is declared
+--       synchronized, or is derived from synchronized interfaces.
+
 --    Is_Tag (Flag78)
 --       Present in E_Component. For regular tagged type this flag is set on
 --       the tag component (whose name is Name_uTag) and for CPP_Class tagged
@@ -2367,6 +2382,10 @@ package Einfo is
 --    Is_Tagged_Type (Flag55)
 --       Present in all entities, true for an entity for a tagged type.
 
+--    Is_Task_Interface (Flag200)
+--       Present in types that are interfaces. True is interface is declared
+--        as such, or if it is derived from task interfaces.
+
 --    Is_Task_Record_Type (synthesized)
 --       Applies to all entities, true if Is_Concurrent_Record_Type
 --       Corresponding_Concurrent_Type is a task type.
@@ -2732,8 +2751,8 @@ package Einfo is
 --       formals as a value of type Pos.
 
 --    Obsolescent_Warning (Node24)
---       Present in subprogram entities. Set non-empty only if the pragma
---       Obsolescent had a string argument, in which case it records the
+--       Present in package and subprogram entities. Set non-empty only if the
+--       pragma Obsolescent had a string argument, in which case it records the
 --       contents of the corresponding string literal node.
 
 --    Original_Access_Type (Node21)
@@ -2778,6 +2797,18 @@ package Einfo is
 --       Present in subprograms. For overriding operations, points to the
 --       user-defined parent subprogram that is being overridden.
 
+--    Package_Instantiation (Node26)
+--       Present in packages and generic packages. When present, this field
+--       references an N_Package_Instantiation node associated with an
+--       instantiated package. In the case where the referenced node has
+--       been rewritten to an N_Package_Specification, the instantiation
+--       node is available from the Original_Node field of the package spec
+--       node. This is currently not guaranteed to be set in all cases, but
+--       when set, the field is used in Get_Package_Instantiation_Node as
+--       one of the means of obtaining the instantiation node. Eventually
+--       it should be set in all cases, including package entities associated
+--       with formal packages. ???
+
 --    Packed_Array_Type (Node23)
 --       Present in array types and subtypes, including the string literal
 --       subtype case, if the corresponding type is packed (either bit packed
@@ -4009,6 +4040,7 @@ package Einfo is
    --    Can_Never_Be_Null             (Flag38)
    --    Checks_May_Be_Suppressed      (Flag31)
    --    Debug_Info_Off                (Flag166)
+   --    Has_Anon_Block_Suffix         (Flag201)
    --    Has_Controlled_Component      (Flag43)   (base type only)
    --    Has_Convention_Pragma         (Flag119)
    --    Has_Delayed_Freeze            (Flag18)
@@ -4123,6 +4155,10 @@ package Einfo is
    --    Is_Frozen                     (Flag4)
    --    Is_Generic_Actual_Type        (Flag94)
    --    Is_Generic_Type               (Flag13)
+   --    Is_Limited_Interface          (Flag197)
+   --    Is_Protected_Interface        (Flag198)
+   --    Is_Synchronized_Interface     (Flag199)
+   --    Is_Task_Interface             (Flag200)
    --    Is_Non_Static_Subtype         (Flag109)
    --    Is_Packed                     (Flag51)   (base type only)
    --    Is_Private_Composite          (Flag107)
@@ -4428,7 +4464,6 @@ package Einfo is
    --    Delay_Cleanups                (Flag114)
    --    Delay_Subprogram_Descriptors  (Flag50)
    --    Discard_Names                 (Flag88)
-   --    Elaborate_All_Desirable       (Flag146)
    --    Has_Completion                (Flag26)
    --    Has_Controlling_Result        (Flag98)
    --    Has_Master_Entity             (Flag21)
@@ -4596,10 +4631,12 @@ package Einfo is
    --    Generic_Renamings             (Elist23)  (for an instance)
    --    Inner_Instances               (Elist23)  (generic case only)
    --    Limited_View                  (Node23)   (non-generic, not instance)
+   --    Obsolescent_Warning           (Node24)
+   --    Current_Use_Clause            (Node25)
+   --    Package_Instantiation         (Node26)
    --    Delay_Subprogram_Descriptors  (Flag50)
    --    Body_Needed_For_SAL           (Flag40)
    --    Discard_Names                 (Flag88)
-   --    Elaborate_All_Desirable       (Flag146)
    --    Elaboration_Entity_Required   (Flag174)
    --    From_With_Type                (Flag159)
    --    Has_All_Calls_Remote          (Flag79)
@@ -4678,7 +4715,6 @@ package Einfo is
    --    Delay_Cleanups                (Flag114)
    --    Delay_Subprogram_Descriptors  (Flag50)
    --    Discard_Names                 (Flag88)
-   --    Elaborate_All_Desirable       (Flag146)
    --    Has_Completion                (Flag26)
    --    Has_Master_Entity             (Flag21)
    --    Has_Nested_Block_With_Handler (Flag101)
@@ -5145,6 +5181,7 @@ package Einfo is
    function Corresponding_Equality             (Id : E) return E;
    function Corresponding_Record_Type          (Id : E) return E;
    function Corresponding_Remote_Type          (Id : E) return E;
+   function Current_Use_Clause                 (Id : E) return E;
    function Current_Value                      (Id : E) return N;
    function Debug_Info_Off                     (Id : E) return B;
    function Debug_Renaming_Link                (Id : E) return E;
@@ -5168,7 +5205,6 @@ package Einfo is
    function Discriminant_Constraint            (Id : E) return L;
    function Discriminant_Default_Value         (Id : E) return N;
    function Discriminant_Number                (Id : E) return U;
-   function Elaborate_All_Desirable            (Id : E) return B;
    function Elaboration_Entity                 (Id : E) return E;
    function Elaboration_Entity_Required        (Id : E) return B;
    function Enclosing_Scope                    (Id : E) return E;
@@ -5208,6 +5244,7 @@ package Einfo is
    function Has_Aliased_Components             (Id : E) return B;
    function Has_Alignment_Clause               (Id : E) return B;
    function Has_All_Calls_Remote               (Id : E) return B;
+   function Has_Anon_Block_Suffix              (Id : E) return B;
    function Has_Atomic_Components              (Id : E) return B;
    function Has_Biased_Representation          (Id : E) return B;
    function Has_Completion                     (Id : E) return B;
@@ -5314,6 +5351,7 @@ package Einfo is
    function Is_Known_Non_Null                  (Id : E) return B;
    function Is_Known_Valid                     (Id : E) return B;
    function Is_Limited_Composite               (Id : E) return B;
+   function Is_Limited_Interface               (Id : E) return B;
    function Is_Machine_Code_Subprogram         (Id : E) return B;
    function Is_Non_Static_Subtype              (Id : E) return B;
    function Is_Null_Init_Proc                  (Id : E) return B;
@@ -5328,6 +5366,7 @@ package Einfo is
 
    function Is_Private_Composite               (Id : E) return B;
    function Is_Private_Descendant              (Id : E) return B;
+   function Is_Protected_Interface             (Id : E) return B;
    function Is_Public                          (Id : E) return B;
    function Is_Pure                            (Id : E) return B;
    function Is_Pure_Unit_Access_Type           (Id : E) return B;
@@ -5336,8 +5375,10 @@ package Einfo is
    function Is_Renaming_Of_Object              (Id : E) return B;
    function Is_Shared_Passive                  (Id : E) return B;
    function Is_Statically_Allocated            (Id : E) return B;
+   function Is_Synchronized_Interface          (Id : E) return B;
    function Is_Tag                             (Id : E) return B;
    function Is_Tagged_Type                     (Id : E) return B;
+   function Is_Task_Interface                  (Id : E) return B;
    function Is_Thread_Body                     (Id : E) return B;
    function Is_True_Constant                   (Id : E) return B;
    function Is_Unchecked_Union                 (Id : E) return B;
@@ -5379,6 +5420,7 @@ package Einfo is
    function Original_Array_Type                (Id : E) return E;
    function Original_Record_Component          (Id : E) return E;
    function Overridden_Operation               (Id : E) return E;
+   function Package_Instantiation              (Id : E) return N;
    function Packed_Array_Type                  (Id : E) return E;
    function Parent_Subtype                     (Id : E) return E;
    function Primitive_Operations               (Id : E) return L;
@@ -5519,7 +5561,7 @@ package Einfo is
    function Is_Dynamic_Scope                   (Id : E) return B;
    function Is_Indefinite_Subtype              (Id : E) return B;
    function Is_Limited_Type                    (Id : E) return B;
-   function Is_Package                         (Id : E) return B;
+   function Is_Package_Or_Generic_Package      (Id : E) return B;
    function Is_Protected_Private               (Id : E) return B;
    function Is_Protected_Record_Type           (Id : E) return B;
    function Is_Return_By_Reference_Type        (Id : E) return B;
@@ -5638,6 +5680,7 @@ package Einfo is
    procedure Set_Corresponding_Equality        (Id : E; V : E);
    procedure Set_Corresponding_Record_Type     (Id : E; V : E);
    procedure Set_Corresponding_Remote_Type     (Id : E; V : E);
+   procedure Set_Current_Use_Clause            (Id : E; V : E);
    procedure Set_Current_Value                 (Id : E; V : N);
    procedure Set_Debug_Info_Off                (Id : E; V : B := True);
    procedure Set_Debug_Renaming_Link           (Id : E; V : E);
@@ -5661,7 +5704,6 @@ package Einfo is
    procedure Set_Discriminant_Constraint       (Id : E; V : L);
    procedure Set_Discriminant_Default_Value    (Id : E; V : N);
    procedure Set_Discriminant_Number           (Id : E; V : U);
-   procedure Set_Elaborate_All_Desirable       (Id : E; V : B := True);
    procedure Set_Elaboration_Entity            (Id : E; V : E);
    procedure Set_Elaboration_Entity_Required   (Id : E; V : B := True);
    procedure Set_Enclosing_Scope               (Id : E; V : E);
@@ -5700,6 +5742,7 @@ package Einfo is
    procedure Set_Has_Aliased_Components        (Id : E; V : B := True);
    procedure Set_Has_Alignment_Clause          (Id : E; V : B := True);
    procedure Set_Has_All_Calls_Remote          (Id : E; V : B := True);
+   procedure Set_Has_Anon_Block_Suffix         (Id : E; V : B := True);
    procedure Set_Has_Atomic_Components         (Id : E; V : B := True);
    procedure Set_Has_Biased_Representation     (Id : E; V : B := True);
    procedure Set_Has_Completion                (Id : E; V : B := True);
@@ -5810,6 +5853,7 @@ package Einfo is
    procedure Set_Is_Known_Non_Null             (Id : E; V : B := True);
    procedure Set_Is_Known_Valid                (Id : E; V : B := True);
    procedure Set_Is_Limited_Composite          (Id : E; V : B := True);
+   procedure Set_Is_Limited_Interface          (Id : E; V : B := True);
    procedure Set_Is_Limited_Record             (Id : E; V : B := True);
    procedure Set_Is_Machine_Code_Subprogram    (Id : E; V : B := True);
    procedure Set_Is_Non_Static_Subtype         (Id : E; V : B := True);
@@ -5823,9 +5867,9 @@ package Einfo is
    procedure Set_Is_Potentially_Use_Visible    (Id : E; V : B := True);
    procedure Set_Is_Preelaborated              (Id : E; V : B := True);
    procedure Set_Is_Primitive_Wrapper          (Id : E; V : B := True);
-
    procedure Set_Is_Private_Composite          (Id : E; V : B := True);
    procedure Set_Is_Private_Descendant         (Id : E; V : B := True);
+   procedure Set_Is_Protected_Interface        (Id : E; V : B := True);
    procedure Set_Is_Public                     (Id : E; V : B := True);
    procedure Set_Is_Pure                       (Id : E; V : B := True);
    procedure Set_Is_Pure_Unit_Access_Type      (Id : E; V : B := True);
@@ -5834,8 +5878,10 @@ package Einfo is
    procedure Set_Is_Renaming_Of_Object         (Id : E; V : B := True);
    procedure Set_Is_Shared_Passive             (Id : E; V : B := True);
    procedure Set_Is_Statically_Allocated       (Id : E; V : B := True);
+   procedure Set_Is_Synchronized_Interface     (Id : E; V : B := True);
    procedure Set_Is_Tag                        (Id : E; V : B := True);
    procedure Set_Is_Tagged_Type                (Id : E; V : B := True);
+   procedure Set_Is_Task_Interface             (Id : E; V : B := True);
    procedure Set_Is_Thread_Body                (Id : E; V : B := True);
    procedure Set_Is_True_Constant              (Id : E; V : B := True);
    procedure Set_Is_Unchecked_Union            (Id : E; V : B := True);
@@ -5876,6 +5922,7 @@ package Einfo is
    procedure Set_Original_Array_Type           (Id : E; V : E);
    procedure Set_Original_Record_Component     (Id : E; V : E);
    procedure Set_Overridden_Operation          (Id : E; V : E);
+   procedure Set_Package_Instantiation         (Id : E; V : N);
    procedure Set_Packed_Array_Type             (Id : E; V : E);
    procedure Set_Parent_Subtype                (Id : E; V : E);
    procedure Set_Primitive_Operations          (Id : E; V : L);
@@ -6185,6 +6232,7 @@ package Einfo is
    pragma Inline (Corresponding_Equality);
    pragma Inline (Corresponding_Record_Type);
    pragma Inline (Corresponding_Remote_Type);
+   pragma Inline (Current_Use_Clause);
    pragma Inline (Current_Value);
    pragma Inline (Debug_Info_Off);
    pragma Inline (Debug_Renaming_Link);
@@ -6208,7 +6256,6 @@ package Einfo is
    pragma Inline (Discriminant_Constraint);
    pragma Inline (Discriminant_Default_Value);
    pragma Inline (Discriminant_Number);
-   pragma Inline (Elaborate_All_Desirable);
    pragma Inline (Elaboration_Entity);
    pragma Inline (Elaboration_Entity_Required);
    pragma Inline (Enclosing_Scope);
@@ -6247,6 +6294,7 @@ package Einfo is
    pragma Inline (Has_Aliased_Components);
    pragma Inline (Has_Alignment_Clause);
    pragma Inline (Has_All_Calls_Remote);
+   pragma Inline (Has_Anon_Block_Suffix);
    pragma Inline (Has_Atomic_Components);
    pragma Inline (Has_Biased_Representation);
    pragma Inline (Has_Completion);
@@ -6377,6 +6425,7 @@ package Einfo is
    pragma Inline (Is_Known_Non_Null);
    pragma Inline (Is_Known_Valid);
    pragma Inline (Is_Limited_Composite);
+   pragma Inline (Is_Limited_Interface);
    pragma Inline (Is_Limited_Record);
    pragma Inline (Is_Machine_Code_Subprogram);
    pragma Inline (Is_Modular_Integer_Type);
@@ -6400,6 +6449,7 @@ package Einfo is
    pragma Inline (Is_Private_Composite);
    pragma Inline (Is_Private_Descendant);
    pragma Inline (Is_Private_Type);
+   pragma Inline (Is_Protected_Interface);
    pragma Inline (Is_Protected_Type);
    pragma Inline (Is_Public);
    pragma Inline (Is_Pure);
@@ -6414,8 +6464,10 @@ package Einfo is
    pragma Inline (Is_Signed_Integer_Type);
    pragma Inline (Is_Statically_Allocated);
    pragma Inline (Is_Subprogram);
+   pragma Inline (Is_Synchronized_Interface);
    pragma Inline (Is_Tag);
    pragma Inline (Is_Tagged_Type);
+   pragma Inline (Is_Task_Interface);
    pragma Inline (Is_Thread_Body);
    pragma Inline (Is_True_Constant);
    pragma Inline (Is_Task_Type);
@@ -6459,6 +6511,7 @@ package Einfo is
    pragma Inline (Original_Array_Type);
    pragma Inline (Original_Record_Component);
    pragma Inline (Overridden_Operation);
+   pragma Inline (Package_Instantiation);
    pragma Inline (Packed_Array_Type);
    pragma Inline (Parameter_Mode);
    pragma Inline (Parent_Subtype);
@@ -6552,6 +6605,7 @@ package Einfo is
    pragma Inline (Set_Corresponding_Equality);
    pragma Inline (Set_Corresponding_Record_Type);
    pragma Inline (Set_Corresponding_Remote_Type);
+   pragma Inline (Set_Current_Use_Clause);
    pragma Inline (Set_Current_Value);
    pragma Inline (Set_Debug_Info_Off);
    pragma Inline (Set_Debug_Renaming_Link);
@@ -6574,7 +6628,6 @@ package Einfo is
    pragma Inline (Set_Discriminant_Constraint);
    pragma Inline (Set_Discriminant_Default_Value);
    pragma Inline (Set_Discriminant_Number);
-   pragma Inline (Set_Elaborate_All_Desirable);
    pragma Inline (Set_Elaboration_Entity);
    pragma Inline (Set_Elaboration_Entity_Required);
    pragma Inline (Set_Enclosing_Scope);
@@ -6611,6 +6664,7 @@ package Einfo is
    pragma Inline (Set_Has_Aliased_Components);
    pragma Inline (Set_Has_Alignment_Clause);
    pragma Inline (Set_Has_All_Calls_Remote);
+   pragma Inline (Set_Has_Anon_Block_Suffix);
    pragma Inline (Set_Has_Atomic_Components);
    pragma Inline (Set_Has_Biased_Representation);
    pragma Inline (Set_Has_Completion);
@@ -6720,6 +6774,7 @@ package Einfo is
    pragma Inline (Set_Is_Known_Non_Null);
    pragma Inline (Set_Is_Known_Valid);
    pragma Inline (Set_Is_Limited_Composite);
+   pragma Inline (Set_Is_Limited_Interface);
    pragma Inline (Set_Is_Limited_Record);
    pragma Inline (Set_Is_Machine_Code_Subprogram);
    pragma Inline (Set_Is_Non_Static_Subtype);
@@ -6736,6 +6791,7 @@ package Einfo is
 
    pragma Inline (Set_Is_Private_Composite);
    pragma Inline (Set_Is_Private_Descendant);
+   pragma Inline (Set_Is_Protected_Interface);
    pragma Inline (Set_Is_Public);
    pragma Inline (Set_Is_Pure);
    pragma Inline (Set_Is_Pure_Unit_Access_Type);
@@ -6744,8 +6800,10 @@ package Einfo is
    pragma Inline (Set_Is_Renaming_Of_Object);
    pragma Inline (Set_Is_Shared_Passive);
    pragma Inline (Set_Is_Statically_Allocated);
+   pragma Inline (Set_Is_Synchronized_Interface);
    pragma Inline (Set_Is_Tag);
    pragma Inline (Set_Is_Tagged_Type);
+   pragma Inline (Set_Is_Task_Interface);
    pragma Inline (Set_Is_Thread_Body);
    pragma Inline (Set_Is_True_Constant);
    pragma Inline (Set_Is_Unchecked_Union);
@@ -6786,6 +6844,7 @@ package Einfo is
    pragma Inline (Set_Original_Array_Type);
    pragma Inline (Set_Original_Record_Component);
    pragma Inline (Set_Overridden_Operation);
+   pragma Inline (Set_Package_Instantiation);
    pragma Inline (Set_Packed_Array_Type);
    pragma Inline (Set_Parent_Subtype);
    pragma Inline (Set_Primitive_Operations);
@@ -6849,7 +6908,7 @@ package Einfo is
    --  things here which are small, but not of the canonical attribute
    --  access/set format that can be handled by xeinfo.
 
-   pragma Inline (Is_Package);
+   pragma Inline (Is_Package_Or_Generic_Package);
    pragma Inline (Is_Wrapper_Package);
    pragma Inline (Known_RM_Size);
    pragma Inline (Known_Static_Component_Bit_Offset);

gcc/ada/exp_ch3.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -79,13 +79,6 @@ package body Exp_Ch3 is
    --  used for attachment of any actions required in its construction.
    --  It also supplies the source location used for the procedure.
 
-   procedure Build_Class_Wide_Master (T : Entity_Id);
-   --  for access to class-wide limited types we must build a task master
-   --  because some subsequent extension may add a task component. To avoid
-   --  bringing in the tasking run-time whenever an access-to-class-wide
-   --  limited type is used, we use the soft-link mechanism and add a level
-   --  of indirection to calls to routines that manipulate Master_Ids.
-
    function Build_Discriminant_Formals
      (Rec_Id : Entity_Id;
       Use_Dl : Boolean) return List_Id;
@@ -651,6 +644,7 @@ package body Exp_Ch3 is
       M_Id : Entity_Id;
       Decl : Node_Id;
       P    : Node_Id;
+      Par  : Node_Id;
 
    begin
       --  Nothing to do if there is no task hierarchy
@@ -659,6 +653,16 @@ package body Exp_Ch3 is
          return;
       end if;
 
+      --  Find declaration that created the access type: either a
+      --  type declaration, or an object declaration with an
+      --  access definition, in which case the type is anonymous.
+
+      if Is_Itype (T) then
+         P := Associated_Node_For_Itype (T);
+      else
+         P := Parent (T);
+      end if;
+
       --  Nothing to do if we already built a master entity for this scope
 
       if not Has_Master_Entity (Scope (T)) then
@@ -677,24 +681,24 @@ package body Exp_Ch3 is
                Make_Explicit_Dereference (Loc,
                  New_Reference_To (RTE (RE_Current_Master), Loc)));
 
-         P := Parent (T);
          Insert_Before (P, Decl);
          Analyze (Decl);
          Set_Has_Master_Entity (Scope (T));
 
          --  Now mark the containing scope as a task master
 
-         while Nkind (P) /= N_Compilation_Unit loop
-            P := Parent (P);
+         Par := P;
+         while Nkind (Par) /= N_Compilation_Unit loop
+            Par := Parent (Par);
 
             --  If we fall off the top, we are at the outer level, and the
             --  environment task is our effective master, so nothing to mark.
 
-            if Nkind (P) = N_Task_Body
-              or else Nkind (P) = N_Block_Statement
-              or else Nkind (P) = N_Subprogram_Body
+            if Nkind (Par) = N_Task_Body
+              or else Nkind (Par) = N_Block_Statement
+              or else Nkind (Par) = N_Subprogram_Body
             then
-               Set_Is_Task_Master (P, True);
+               Set_Is_Task_Master (Par, True);
                exit;
             end if;
          end loop;
@@ -711,7 +715,7 @@ package body Exp_Ch3 is
           Defining_Identifier => M_Id,
           Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
           Name => Make_Identifier (Loc, Name_uMaster));
-      Insert_Before (Parent (T), Decl);
+      Insert_Before (P, Decl);
       Analyze (Decl);
 
       Set_Master_Id (T, M_Id);
@@ -1758,11 +1762,19 @@ package body Exp_Ch3 is
                Aux_N : Node_Id;
 
             begin
-               if not Is_Interface (Typ)
-                 and then Etype (Typ) /= Typ
-               then
+               if not Is_Interface (Typ) then
+
+                  --  Climb to the ancestor (if any) handling private types
+
+                  if Present (Full_View (Etype (Typ))) then
+                     if Full_View (Etype (Typ)) /= Typ then
+                        Init_Secondary_Tags_Internal (Full_View (Etype (Typ)));
+                     end if;
+
+                  elsif Etype (Typ) /= Typ then
                      Init_Secondary_Tags_Internal (Etype (Typ));
                   end if;
+               end if;
 
                if Present (Abstract_Interfaces (Typ))
                  and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
@@ -1824,7 +1836,14 @@ package body Exp_Ch3 is
             --  interfaces.
 
             ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+
+            --  Handle private types
+
+            if Present (Full_View (Typ)) then
+               Init_Secondary_Tags_Internal (Full_View (Typ));
+            else
                Init_Secondary_Tags_Internal (Typ);
+            end if;
          end Init_Secondary_Tags;
 
       --  Start of processing for Build_Init_Procedure
@@ -2478,6 +2497,13 @@ package body Exp_Ch3 is
             return False;
          end if;
 
+         --  If it is a type derived from a type with unknown discriminants,
+         --  we cannot build an initialization procedure for it.
+
+         if Has_Unknown_Discriminants (Rec_Id) then
+            return False;
+         end if;
+
          --  Otherwise we need to generate an initialization procedure if
          --  Is_CPP_Class is False and at least one of the following applies:
 
@@ -4547,7 +4573,7 @@ package body Exp_Ch3 is
                   ADT : Elist_Id := Access_Disp_Table (Def_Id);
 
                   procedure Add_Secondary_Tables (Typ : Entity_Id);
-                  --  Comment required ???
+                  --  Internal subprogram, recursively climb to the ancestors
 
                   --------------------------
                   -- Add_Secondary_Tables --
@@ -4555,26 +4581,44 @@ package body Exp_Ch3 is
 
                   procedure Add_Secondary_Tables (Typ : Entity_Id) is
                      E            : Entity_Id;
+                     Iface        : Elmt_Id;
                      Result       : List_Id;
+                     Suffix_Index : Int;
 
                   begin
-                     if Etype (Typ) /= Typ then
+                     --  Climb to the ancestor (if any) handling private types
+
+                     if Present (Full_View (Etype (Typ))) then
+                        if Full_View (Etype (Typ)) /= Typ then
+                           Add_Secondary_Tables (Full_View (Etype (Typ)));
+                        end if;
+
+                     elsif Etype (Typ) /= Typ then
                         Add_Secondary_Tables (Etype (Typ));
                      end if;
 
                      if Present (Abstract_Interfaces (Typ))
-                       and then not Is_Empty_Elmt_List
-                                      (Abstract_Interfaces (Typ))
+                       and then
+                         not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
                      then
+                        Iface := First_Elmt (Abstract_Interfaces (Typ));
+                        Suffix_Index := 0;
+
                         E := First_Entity (Typ);
                         while Present (E) loop
                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
-                              Make_Abstract_Interface_DT
-                                (AI_Tag          => E,
+                              Make_Secondary_DT
+                                (Typ             => Def_Id,
+                                 Ancestor_Typ    => Typ,
+                                 Suffix_Index    => Suffix_Index,
+                                 Iface           => Node (Iface),
+                                 AI_Tag          => E,
                                  Acc_Disp_Tables => ADT,
                                  Result          => Result);
 
                               Append_Freeze_Actions (Def_Id, Result);
+                              Suffix_Index := Suffix_Index + 1;
+                              Next_Elmt (Iface);
                            end if;
 
                            Next_Entity (E);
@@ -4585,7 +4629,14 @@ package body Exp_Ch3 is
                --  Start of processing to build secondary dispatch tables
 
                begin
+                  --  Handle private types
+
+                  if Present (Full_View (Def_Id)) then
+                     Add_Secondary_Tables  (Full_View (Def_Id));
+                  else
                      Add_Secondary_Tables  (Def_Id);
+                  end if;
+
                   Set_Access_Disp_Table (Def_Id, ADT);
                   Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
                end;
@@ -4699,9 +4750,14 @@ package body Exp_Ch3 is
            and then not Is_Interface  (Def_Id)
            and then not Is_Abstract   (Def_Id)
            and then not Is_Controlled (Def_Id)
-           and then Implements_Limited_Interface (Def_Id)
+           and then
+             Implements_Interface
+               (Typ          => Def_Id,
+                Kind         => Any_Limited_Interface,
+                Check_Parent => True)
          then
-            Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id));
+            Append_Freeze_Actions (Def_Id,
+              Make_Select_Specific_Data_Table (Def_Id));
          end if;
       end if;
    end Freeze_Record_Type;
@@ -5897,6 +5953,7 @@ package body Exp_Ch3 is
       --    disp_asynchronous_select
       --    disp_conditional_select
       --    disp_get_prim_op_kind
+      --    disp_get_task_id
       --    disp_timed_select
       --  for limited interfaces and tagged types that implement a limited
       --  interface.
@@ -5908,51 +5965,37 @@ package body Exp_Ch3 is
           or else
              (not Is_Abstract (Tag_Typ)
                 and then not Is_Controlled (Tag_Typ)
-                and then Implements_Limited_Interface (Tag_Typ)))
+              and then
+                Implements_Interface
+                  (Typ          => Tag_Typ,
+                   Kind         => Any_Limited_Interface,
+                   Check_Parent => True)))
       then
-         if Is_Interface (Tag_Typ) then
          Append_To (Res,
-              Make_Abstract_Subprogram_Declaration (Loc,
+           Make_Subprogram_Declaration (Loc,
              Specification =>
                Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
 
          Append_To (Res,
-              Make_Abstract_Subprogram_Declaration (Loc,
-                Specification =>
-                  Make_Disp_Conditional_Select_Spec (Tag_Typ)));
-
-            Append_To (Res,
-              Make_Abstract_Subprogram_Declaration (Loc,
-                Specification =>
-                  Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
-
-            Append_To (Res,
-              Make_Abstract_Subprogram_Declaration (Loc,
-                Specification =>
-                  Make_Disp_Timed_Select_Spec (Tag_Typ)));
-
-         else
-            Append_To (Res,
            Make_Subprogram_Declaration (Loc,
              Specification =>
-                  Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+               Make_Disp_Conditional_Select_Spec (Tag_Typ)));
 
          Append_To (Res,
            Make_Subprogram_Declaration (Loc,
              Specification =>
-                  Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+               Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
 
          Append_To (Res,
            Make_Subprogram_Declaration (Loc,
              Specification =>
-                  Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+               Make_Disp_Get_Task_Id_Spec (Tag_Typ)));
 
          Append_To (Res,
            Make_Subprogram_Declaration (Loc,
              Specification =>
                Make_Disp_Timed_Select_Spec (Tag_Typ)));
       end if;
-      end if;
 
       --  Specs for finalization actions that may be required in case a
       --  future extension contain a controlled element. We generate those
@@ -6310,26 +6353,33 @@ package body Exp_Ch3 is
       end if;
 
       --  Generate the bodies for the following primitive operations:
+
       --    disp_asynchronous_select
       --    disp_conditional_select
       --    disp_get_prim_op_kind
+      --    disp_get_task_id
       --    disp_timed_select
-      --  for tagged types that implement a limited interface.
+
+      --  for limited interfaces and tagged types that implement a limited
+      --  interface. The interface versions will have null bodies.
 
       if Ada_Version >= Ada_05
-        and then not Is_Interface  (Tag_Typ)
-        and then not Is_Abstract   (Tag_Typ)
+        and then
+          ((Is_Interface (Tag_Typ) and then Is_Limited_Record (Tag_Typ))
+              or else
+                (not Is_Abstract (Tag_Typ)
                    and then not Is_Controlled (Tag_Typ)
-        and then Implements_Limited_Interface (Tag_Typ)
+                   and then
+                     Implements_Interface
+                       (Typ          => Tag_Typ,
+                        Kind         => Any_Limited_Interface,
+                        Check_Parent => True)))
       then
-         Append_To (Res,
-           Make_Disp_Asynchronous_Select_Body (Tag_Typ));
-         Append_To (Res,
-           Make_Disp_Conditional_Select_Body  (Tag_Typ));
-         Append_To (Res,
-           Make_Disp_Get_Prim_Op_Kind_Body    (Tag_Typ));
-         Append_To (Res,
-           Make_Disp_Timed_Select_Body        (Tag_Typ));
+         Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
+         Append_To (Res, Make_Disp_Conditional_Select_Body  (Tag_Typ));
+         Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body    (Tag_Typ));
+         Append_To (Res, Make_Disp_Get_Task_Id_Body         (Tag_Typ));
+         Append_To (Res, Make_Disp_Timed_Select_Body        (Tag_Typ));
       end if;
 
       if not Is_Limited_Type (Tag_Typ) then
@@ -6337,8 +6387,8 @@ package body Exp_Ch3 is
          --  Body for equality
 
          if Eq_Needed then
-
-            Decl := Predef_Spec_Or_Body (Loc,
+            Decl :=
+              Predef_Spec_Or_Body (Loc,
                 Tag_Typ => Tag_Typ,
                 Name    => Eq_Name,
                 Profile => New_List (
@@ -6403,7 +6453,8 @@ package body Exp_Ch3 is
 
          --  Body for dispatching assignment
 
-         Decl := Predef_Spec_Or_Body (Loc,
+         Decl :=
+           Predef_Spec_Or_Body (Loc,
              Tag_Typ => Tag_Typ,
              Name    => Name_uAssign,
              Profile => New_List (
@@ -6541,6 +6592,7 @@ package body Exp_Ch3 is
       return
         not (Is_Limited_Type (Typ)
                and then not Has_Inheritable_Stream_Attribute)
+          and then not Has_Unknown_Discriminants (Typ)
           and then RTE_Available (RE_Tag)
           and then RTE_Available (RE_Root_Stream_Type)
           and then not Restriction_Active (No_Dispatch)

gcc/ada/exp_ch3.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---           Copyright (C) 1992-2005 Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2005, 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- --
@@ -40,12 +40,21 @@ package Exp_Ch3 is
    procedure Expand_Previous_Access_Type (Def_Id : Entity_Id);
    --  For a full type declaration that contains tasks, or that is a task,
    --  check whether there exists an access type whose designated type is an
-   --  incomplete declarations for the current composite type. If so, build
-   --  the master for that access type, now that it is known to denote an
-   --  object with tasks.
+   --  incomplete declarations for the current composite type. If so, build the
+   --  master for that access type, now that it is known to denote an object
+   --  with tasks.
 
    procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
-   --  Add a field _parent in the extension part of the record.
+   --  Add a field _parent in the extension part of the record
+
+   procedure Build_Class_Wide_Master (T : Entity_Id);
+   --  For access to class-wide limited types we must build a task master
+   --  because some subsequent extension may add a task component. To avoid
+   --  bringing in the tasking run-time whenever an access-to-class-wide
+   --  limited type is used, we use the soft-link mechanism and add a level of
+   --  indirection to calls to routines that manipulate Master_Ids. This must
+   --  also be used for anonymous access types whose designated type is a task
+   --  or synchronized interface.
 
    procedure Build_Discr_Checking_Funcs (N : Node_Id);
    --  Builds function which checks whether the component name is consistent
@@ -66,10 +75,10 @@ package Exp_Ch3 is
    --  constructed tree, and Typ is the type of the entity (the initialization
    --  procedure of the base type is the procedure that actually gets called).
    --  In_Init_Proc has to be set to True when the call is itself in an init
-   --  proc in order to enable the use of discriminals. Enclos_type is the
-   --  type of the init proc and it is used for various expansion cases
-   --  including the case where Typ is a task type which is a array component,
-   --  the indices of the enclosing type are used to build the string that
+   --  proc in order to enable the use of discriminals. Enclos_type is the type
+   --  of the init proc and it is used for various expansion cases including
+   --  the case where Typ is a task type which is a array component, the
+   --  indices of the enclosing type are used to build the string that
    --  identifies each task at runtime.
    --
    --  Discr_Map is used to replace discriminants by their discriminals in
@@ -84,33 +93,32 @@ package Exp_Ch3 is
 
    function Freeze_Type (N : Node_Id) return Boolean;
    --  This function executes the freezing actions associated with the given
-   --  freeze type node N and returns True if the node is to be deleted.
-   --  We delete the node if it is present just for front end purpose and
-   --  we don't want Gigi to see the node.  This function can't delete the
-   --  node itself since it would confuse any remaining processing of the
-   --  freeze node.
+   --  freeze type node N and returns True if the node is to be deleted. We
+   --  delete the node if it is present just for front end purpose and we don't
+   --  want Gigi to see the node. This function can't delete the node itself
+   --  since it would confuse any remaining processing of the freeze node.
 
    function Needs_Simple_Initialization (T : Entity_Id) return Boolean;
    --  Certain types need initialization even though there is no specific
-   --  initialization routine. In this category are access types (which
-   --  need initializing to null), packed array types whose implementation
-   --  is a modular type, and all scalar types if Normalize_Scalars is set,
-   --  as well as private types whose underlying type is present and meets
-   --  any of these criteria. Finally, descendants of String and Wide_String
-   --  also need initialization in Initialize/Normalize_Scalars mode.
+   --  initialization routine. In this category are access types (which need
+   --  initializing to null), packed array types whose implementation is a
+   --  modular type, and all scalar types if Normalize_Scalars is set, as well
+   --  as private types whose underlying type is present and meets any of these
+   --  criteria. Finally, descendants of String and Wide_String also need
+   --  initialization in Initialize/Normalize_Scalars mode.
 
    function Get_Simple_Init_Val
      (T    : Entity_Id;
       Loc  : Source_Ptr;
       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.
+   --  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.
 
 end Exp_Ch3;

gcc/ada/exp_ch6.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -99,10 +99,11 @@ package body Exp_Ch6 is
    --  we have an infinite recursion.
 
    procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
-   --  For each actual of an in-out parameter which is a numeric conversion
-   --  of the form T(A), where A denotes a variable, we insert the declaration:
+   --  For each actual of an in-out or out parameter which is a numeric
+   --  (view) conversion of the form T (A), where A denotes a variable,
+   --  we insert the declaration:
    --
-   --    Temp : T := T (A);
+   --    Temp : T[ := T (A)];
    --
    --  prior to the call. Then we replace the actual with a reference to Temp,
    --  and append the assignment:
@@ -1464,6 +1465,48 @@ package body Exp_Ch6 is
          end if;
       end if;
 
+      --  Ada 2005 (AI-345): We have a procedure call as a triggering
+      --  alternative in an asynchronous select or as an entry call in
+      --  a conditional or timed select. Check whether the procedure call
+      --  is a renaming of an entry and rewrite it as an entry call.
+
+      if Ada_Version >= Ada_05
+        and then Nkind (N) = N_Procedure_Call_Statement
+        and then
+           ((Nkind (Parent (N)) = N_Triggering_Alternative
+               and then Triggering_Statement (Parent (N)) = N)
+          or else
+            (Nkind (Parent (N)) = N_Entry_Call_Alternative
+               and then Entry_Call_Statement (Parent (N)) = N))
+      then
+         declare
+            Ren_Decl : Node_Id;
+            Ren_Root : Entity_Id := Subp;
+
+         begin
+            --  This may be a chain of renamings, find the root
+
+            if Present (Alias (Ren_Root)) then
+               Ren_Root := Alias (Ren_Root);
+            end if;
+
+            if Present (Original_Node (Parent (Parent (Ren_Root)))) then
+               Ren_Decl := Original_Node (Parent (Parent (Ren_Root)));
+
+               if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then
+                  Rewrite (N,
+                    Make_Entry_Call_Statement (Loc,
+                      Name =>
+                        New_Copy_Tree (Name (Ren_Decl)),
+                      Parameter_Associations =>
+                        New_Copy_List_Tree (Parameter_Associations (N))));
+
+                  return;
+               end if;
+            end if;
+         end;
+      end if;
+
       --  First step, compute extra actuals, corresponding to any
       --  Extra_Formals present. Note that we do not access Extra_Formals
       --  directly, instead we simply note the presence of the extra
@@ -1558,13 +1601,29 @@ package body Exp_Ch6 is
                      Act_Prev := Expression (Act_Prev);
                   end loop;
 
-                  Add_Extra_Actual (
-                    Make_Attribute_Reference (Sloc (Prev),
+                  --  If the expression is a conversion of a dereference,
+                  --  this is internally generated code that manipulates
+                  --  addresses, e.g. when building interface tables. No
+                  --  check should occur in this case, and the discriminated
+                  --  object is not directly a hand.
+
+                  if not Comes_From_Source (Actual)
+                    and then Nkind (Actual) = N_Unchecked_Type_Conversion
+                    and then Nkind (Act_Prev) = N_Explicit_Dereference
+                  then
+                     Add_Extra_Actual
+                       (New_Occurrence_Of (Standard_False, Loc),
+                        Extra_Constrained (Formal));
+
+                  else
+                     Add_Extra_Actual
+                       (Make_Attribute_Reference (Sloc (Prev),
                         Prefix =>
                           Duplicate_Subexpr_No_Checks
                             (Act_Prev, Name_Req => True),
                         Attribute_Name => Name_Constrained),
                         Extra_Constrained (Formal));
+                  end if;
                end;
             end if;
          end if;
@@ -1591,8 +1650,8 @@ package body Exp_Ch6 is
                      pragma Assert (Present (Parm_Ent));
 
                      if Present (Extra_Accessibility (Parm_Ent)) then
-                        Add_Extra_Actual (
-                          New_Occurrence_Of
+                        Add_Extra_Actual
+                          (New_Occurrence_Of
                              (Extra_Accessibility (Parm_Ent), Loc),
                            Extra_Accessibility (Formal));
 
@@ -1602,8 +1661,8 @@ package body Exp_Ch6 is
                      --  accessibility.
 
                      else
-                        Add_Extra_Actual (
-                          Make_Integer_Literal (Loc,
+                        Add_Extra_Actual
+                          (Make_Integer_Literal (Loc,
                            Intval => Scope_Depth (Standard_Standard)),
                            Extra_Accessibility (Formal));
                      end if;
@@ -1613,8 +1672,8 @@ package body Exp_Ch6 is
                --  level of the actual's access type.
 
                else
-                  Add_Extra_Actual (
-                    Make_Integer_Literal (Loc,
+                  Add_Extra_Actual
+                    (Make_Integer_Literal (Loc,
                      Intval => Type_Access_Level (Etype (Prev_Orig))),
                      Extra_Accessibility (Formal));
                end if;
@@ -3092,6 +3151,12 @@ package body Exp_Ch6 is
       --  If the call is the right side of an assignment or the expression in
       --  an object declaration, we don't need to create a temp as the left
       --  side will already trigger stack checking if necessary.
+      --
+      --  If the call is a component in an extension aggregate, it will be
+      --  expanded into assignments as well, so no temporary is needed. This
+      --  also solves the problem of functions returning types with unknown
+      --  discriminants, where it is not possible to declare an object of the
+      --  type altogether.
 
       ---------------------------
       -- Returned_By_Reference --
@@ -3143,6 +3208,9 @@ package body Exp_Ch6 is
                 and then Expression (Parent (N)) = N
                   and then Nkind (Parent (Parent (N))) = N_Aggregate
                     and then Rhs_Of_Assign_Or_Decl (Parent (Parent (N))))
+           or else
+             (Nkind (Parent (N)) = N_Extension_Aggregate
+               and then Is_Private_Type (Etype (Typ)))
          then
             return True;
          else
@@ -4068,6 +4136,10 @@ package body Exp_Ch6 is
       --  immediate ancestor associated with the interface; otherwise Prim and
       --  Ancestor_Iface_Prim have the same info.
 
+      procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
+      --  (Ada 2005): Register a predefined primitive in all the secondary
+      --  dispatch tables of its primitive type.
+
       -------------------------------------------
       -- Check_Overriding_Inherited_Interfaces --
       -------------------------------------------
@@ -4090,11 +4162,18 @@ package body Exp_Ch6 is
          --  Get the entity associated with this primitive operation
 
          Typ := Scope (DTC_Entity (E));
-         while Etype (Typ) /= Typ loop
+         loop
+            exit when Etype (Typ) = Typ
+              or else (Present (Full_View (Etype (Typ)))
+                         and then Full_View (Etype (Typ)) = Typ);
 
-            --  Climb to the immediate ancestor
+            --  Climb to the immediate ancestor handling private types
 
+            if Present (Full_View (Etype (Typ))) then
+               Typ := Full_View (Etype (Typ));
+            else
                Typ := Etype (Typ);
+            end if;
 
             if Present (Abstract_Interfaces (Typ)) then
 
@@ -4192,16 +4271,20 @@ package body Exp_Ch6 is
          if not Present (Ancestor_Iface_Prim) then
             Prim_Typ  := Scope (DTC_Entity (Alias (Prim)));
             Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim)));
-            Iface_Tag := Find_Interface_Tag
-                           (T     => Prim_Typ,
-                            Iface => Iface_Typ);
 
             --  Generate the code of the thunk only when this primitive
             --  operation is associated with a secondary dispatch table.
 
+            if Is_Interface (Iface_Typ) then
+               Iface_Tag := Find_Interface_Tag
+                              (T     => Prim_Typ,
+                               Iface => Iface_Typ);
+
                if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
-               Thunk_Id  := Make_Defining_Identifier (Loc,
-                              New_Internal_Name ('T'));
+                  Thunk_Id  :=
+                    Make_Defining_Identifier (Loc,
+                      Chars => New_Internal_Name ('T'));
+
                   New_Thunk :=
                     Expand_Interface_Thunk
                       (N           => Prim,
@@ -4222,6 +4305,7 @@ package body Exp_Ch6 is
                       Iface_DT_Ptr => Iface_DT_Ptr,
                       Thunk_Id     => Thunk_Id));
                end if;
+            end if;
 
          else
             Iface_Typ :=
@@ -4243,8 +4327,9 @@ package body Exp_Ch6 is
             --    type T is new I with ...
 
             if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
-               Thunk_Id  := Make_Defining_Identifier (Loc,
-                              New_Internal_Name ('T'));
+               Thunk_Id :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_Internal_Name ('T'));
 
                if Present (Alias (Prim)) then
                   Prim_Op := Alias (Prim);
@@ -4275,6 +4360,70 @@ package body Exp_Ch6 is
          end if;
       end Register_Interface_DT_Entry;
 
+      ----------------------------------
+      -- Register_Predefined_DT_Entry --
+      ----------------------------------
+
+      procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is
+         Iface_DT_Ptr : Elmt_Id;
+         Iface_Tag    : Entity_Id;
+         Iface_Typ    : Elmt_Id;
+         New_Thunk    : Entity_Id;
+         Prim_Typ     : Entity_Id;
+         Thunk_Id     : Entity_Id;
+
+      begin
+         Prim_Typ := Scope (DTC_Entity (Prim));
+
+         if not Present (Access_Disp_Table (Prim_Typ))
+           or else not Present (Abstract_Interfaces (Prim_Typ))
+         then
+            return;
+         end if;
+
+         --  Skip the first acces-to-dispatch-table pointer since it leads
+         --  to the primary dispatch table. We are only concerned with the
+         --  secondary dispatch table pointers. Note that the access-to-
+         --  dispatch-table pointer corresponds to the first implemented
+         --  interface retrieved below.
+
+         Iface_DT_Ptr := Next_Elmt (First_Elmt (Access_Disp_Table (Prim_Typ)));
+         Iface_Typ := First_Elmt (Abstract_Interfaces (Prim_Typ));
+         while Present (Iface_DT_Ptr) and then Present (Iface_Typ) loop
+            Iface_Tag := Find_Interface_Tag (Prim_Typ, Node (Iface_Typ));
+            pragma Assert (Present (Iface_Tag));
+
+            if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
+               Thunk_Id := Make_Defining_Identifier (Loc,
+                             New_Internal_Name ('T'));
+
+               New_Thunk :=
+                 Expand_Interface_Thunk
+                  (N           => Prim,
+                   Thunk_Alias => Prim,
+                   Thunk_Id    => Thunk_Id,
+                   Thunk_Tag   => Iface_Tag);
+
+               Insert_After (N, New_Thunk);
+               Insert_After (New_Thunk,
+                 Make_DT_Access_Action (Node (Iface_Typ),
+                   Action => Set_Prim_Op_Address,
+                   Args   => New_List (
+                     Unchecked_Convert_To (RTE (RE_Tag),
+                       New_Reference_To (Node (Iface_DT_Ptr), Loc)),
+
+                     Make_Integer_Literal (Loc, DT_Position (Prim)),
+
+                     Make_Attribute_Reference (Loc,
+                       Prefix         => New_Reference_To (Thunk_Id, Loc),
+                       Attribute_Name => Name_Address))));
+            end if;
+
+            Next_Elmt (Iface_DT_Ptr);
+            Next_Elmt (Iface_Typ);
+         end loop;
+      end Register_Predefined_DT_Entry;
+
    --  Start of processing for Freeze_Subprogram
 
    begin
@@ -4297,6 +4446,17 @@ package body Exp_Ch6 is
               Fill_DT_Entry (Sloc (N), Prim => E));
 
          else
+            declare
+               Typ : constant Entity_Id := Scope (DTC_Entity (E));
+
+            begin
+               --  There is no dispatch table associated with abstract
+               --  interface types; each type implementing interfaces
+               --  will fill the associated secondary DT entries.
+
+               if not Is_Interface (Typ)
+                 or else Present (Alias (E))
+               then
                   --  Ada 2005 (AI-251): Check if this entry corresponds with
                   --  a subprogram that covers an abstract interface type.
 
@@ -4306,11 +4466,19 @@ package body Exp_Ch6 is
                   --  Common case: Primitive subprogram
 
                   else
+                     --  Generate thunks for all the predefined operations
+
+                     if Is_Predefined_Dispatching_Operation (E) then
+                        Register_Predefined_DT_Entry (E);
+                     end if;
+
                      Insert_After (N,
                        Fill_DT_Entry (Sloc (N), Prim => E));
                      Check_Overriding_Inherited_Interfaces (E);
                   end if;
                end if;
+            end;
+         end if;
       end if;
 
       --  Mark functions that return by reference. Note that it cannot be

gcc/ada/exp_ch7.adb

@@ -1793,6 +1793,13 @@ package body Exp_Ch7 is
                   return The_Parent;
                end if;
 
+            --  A raise statement can be wrapped. This will arise when the
+            --  expression in a raise_with_expression uses the secondary
+            --  stack, for example.
+
+            when N_Raise_Statement  =>
+               return The_Parent;
+
             --  If the expression is within the iteration scheme of a loop,
             --  we must create a declaration for it, followed by an assignment
             --  in order to have a usable statement to wrap.
@@ -2728,13 +2735,27 @@ package body Exp_Ch7 is
       Utyp := Underlying_Type (Base_Type (Utyp));
       Set_Assignment_OK (Cref);
 
-      --  Deal with non-tagged derivation of private views
+      --  Deal with non-tagged derivation of private views. If the parent is
+      --  now known to be protected, the finalization routine is the one
+      --  defined on the corresponding record of the ancestor (corresponding
+      --  records do not automatically inherit operations, but maybe they
+      --  should???)
 
       if Is_Untagged_Derivation (Typ) then
+         if Is_Protected_Type (Typ) then
+            Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+         else
             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
+         end if;
+
          Cref := Unchecked_Convert_To (Utyp, Cref);
+
+         --  We need to set Assignment_OK to prevent problems with unchecked
+         --  conversions, where we do not want them to be converted back in the
+         --  case of untagged record derivation (see code in Make_*_Call
+         --  procedures for similar situations).
+
          Set_Assignment_OK (Cref);
-         --  To prevent problems with UC see 1.156 RH ???
       end if;
 
       --  If the underlying_type is a subtype, we are dealing with

gcc/ada/exp_ch9.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -313,11 +313,19 @@ package Exp_Ch9 is
    procedure Set_Privals
       (Dec           : Node_Id;
        Op            : Node_Id;
-       Loc : Source_Ptr);
+       Loc           : Source_Ptr;
+       After_Barrier : Boolean := False);
    --  Associates a new set of privals (placeholders for later access to
    --  private components of protected objects) with the private object
    --  declarations of a protected object. These will be used to expand
    --  the references to private objects in the next protected
    --  subprogram or entry body to be expanded.
+   --
+   --  The flag After_Barrier indicates whether this is called after building
+   --  the barrier function for an entry body. This flag determines whether
+   --  the privals should have source names (which simplifies debugging) or
+   --  internally generated names. Entry barriers contain no debuggable code,
+   --  and there may be visibility conflicts between an entry index and a
+   --  a prival, so  privals for barrier function have internal names.
 
 end Exp_Ch9;

gcc/ada/exp_dbug.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1996-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1996-2005, 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- --
@@ -134,7 +134,7 @@ package body Exp_Dbug is
    --  used to determine whether encoding is required for a discrete type.
 
    procedure Output_Homonym_Numbers_Suffix;
-   --  If homonym numbers are stored, then output them into Name_Buffer.
+   --  If homonym numbers are stored, then output them into Name_Buffer
 
    procedure Prepend_String_To_Buffer (S : String);
    --  Prepend given string to the contents of the string buffer, updating
@@ -250,9 +250,9 @@ package body Exp_Dbug is
       then
          return True;
 
-      --  Here we check if the static bounds match the natural size, which
-      --  is the size passed through with the debugging information. This
-      --  is the Esize rounded up to 8, 16, 32 or 64 as appropriate.
+      --  Here we check if the static bounds match the natural size, which is
+      --  the size passed through with the debugging information. This is the
+      --  Esize rounded up to 8, 16, 32 or 64 as appropriate.
 
       else
          declare
@@ -305,12 +305,12 @@ package body Exp_Dbug is
       Def : Entity_Id;
 
       function Output_Subscript (N : Node_Id; S : String) return Boolean;
-      --  Outputs a single subscript value as ?nnn (subscript is compile
-      --  time known value with value nnn) or as ?e (subscript is local
-      --  constant with name e), where S supplies the proper string to
-      --  use for ?. Returns False if the subscript is not of an appropriate
-      --  type to output in one of these two forms. The result is prepended
-      --  to the name stored in Name_Buffer.
+      --  Outputs a single subscript value as ?nnn (subscript is compile time
+      --  known value with value nnn) or as ?e (subscript is local constant
+      --  with name e), where S supplies the proper string to use for ?.
+      --  Returns False if the subscript is not of an appropriate type to
+      --  output in one of these two forms. The result is prepended to the
+      --  name stored in Name_Buffer.
 
       ----------------------
       -- Output_Subscript --
@@ -358,9 +358,9 @@ package body Exp_Dbug is
          when N_Package_Renaming_Declaration =>
             Add_Str_To_Name_Buffer ("___XRP");
 
-            --  If it is a child unit create a fully qualified name,
-            --  to disambiguate multiple child units with the same
-            --  name and different parents.
+            --  If it is a child unit create a fully qualified name, to
+            --  disambiguate multiple child units with the same name and
+            --  different parents.
 
             if Is_Child_Unit (Ent) then
                Prepend_String_To_Buffer ("__");
@@ -386,8 +386,8 @@ package body Exp_Dbug is
 
             when N_Expanded_Name =>
 
-               --  The entity field for an N_Expanded_Name is on the
-               --  expanded name node itself, so we are done here too.
+               --  The entity field for an N_Expanded_Name is on the expanded
+               --  name node itself, so we are done here too.
 
                exit;
 
@@ -713,6 +713,7 @@ package body Exp_Dbug is
          --  If this is a library level subprogram (i.e. a subprogram that is a
          --  compilation unit other than a subunit), then we prepend _ada_ to
          --  ensure distinctions required as described in the spec.
+
          --  Check explicitly for child units, because those are not flagged
          --  as Compilation_Units by lib. Should they be ???
 
@@ -880,6 +881,39 @@ package body Exp_Dbug is
       end if;
    end Get_Variant_Encoding;
 
+   ------------------------------------
+   -- Get_Secondary_DT_External_Name --
+   ------------------------------------
+
+   procedure Get_Secondary_DT_External_Name
+     (Typ             : Entity_Id;
+      Ancestor_Typ    : Entity_Id;
+      Suffix_Index    : Int) is
+   begin
+      Get_External_Name (Typ, Has_Suffix => False);
+
+      if Ancestor_Typ /= Typ then
+         declare
+            Len      : constant Natural := Name_Len;
+            Save_Str : constant String (1 .. Name_Len)
+                         := Name_Buffer (1 .. Name_Len);
+         begin
+            Get_External_Name (Ancestor_Typ, Has_Suffix => False);
+
+            --  Append the extended name of the ancestor to the
+            --  extended name of Typ
+
+            Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
+              Name_Buffer (1 .. Name_Len);
+            Name_Buffer (1 .. Len) := Save_Str;
+            Name_Buffer (Len + 1) := '_';
+            Name_Len := Len + Name_Len + 1;
+         end;
+      end if;
+
+      Add_Nat_To_Name_Buffer (Suffix_Index);
+   end Get_Secondary_DT_External_Name;
+
    ---------------------------------
    -- Make_Packed_Array_Type_Name --
    ---------------------------------
@@ -1166,7 +1200,6 @@ package body Exp_Dbug is
          else
             Add_Char_To_Name_Buffer ('X');
          end if;
-
       end Set_BNPE_Suffix;
 
       ---------------------
@@ -1338,7 +1371,6 @@ package body Exp_Dbug is
             exit;
          end if;
       end loop;
-
    end Strip_Suffixes;
 
 end Exp_Dbug;

gcc/ada/exp_dbug.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1996-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1996-2005, 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- --
@@ -360,7 +360,7 @@ package Exp_Dbug is
       --  Operations generated for protected entries follow the same encoding.
       --  Each entry results in two suprograms: a procedure that holds the
       --  entry body, and a function that holds the evaluation of the barrier.
-      --  The names of these subprograms include the prefix 'E' or 'B' res-
+      --  The names of these subprograms include the prefix '_E' or '_B' res-
       --  pectively. The names also include a numeric suffix to render them
       --  unique in the presence of overloaded entries.
 
@@ -382,8 +382,8 @@ package Exp_Dbug is
       --    lock_setN
       --    lock_setP
 
-      --    lock_update1sE
-      --    lock_udpate2sB
+      --    lock_update_E1s
+      --    lock_udpate_B2s
 
       --  If the protected type implements at least one interface, the
       --  following additional operations are created:
@@ -538,6 +538,12 @@ package Exp_Dbug is
       --  field, and neither the outer structure name, nor the field name
       --  should appear when the value is printed.
 
+      --  When the debugger sees a record named REP being a field inside
+      --  another record, it should treat the fields inside REP as being
+      --  part of the outer record (this REP field is only present for
+      --  code generation purposes). The REP record should not appear in
+      --  the values printed by the debugger.
+
       -----------------------
       -- Fixed-Point Types --
       -----------------------
@@ -1432,6 +1438,66 @@ package Exp_Dbug is
    --  the second enumeration literal would be named QU43 and the
    --  value assigned to it would be 1.
 
+   -----------------------------------------------
+   -- Secondary Dispatch tables of tagged types --
+   -----------------------------------------------
+
+   procedure Get_Secondary_DT_External_Name
+     (Typ          : Entity_Id;
+      Ancestor_Typ : Entity_Id;
+      Suffix_Index : Int);
+   --  Set Name_Buffer and Name_Len to the external name of one secondary
+   --  dispatch table of Typ. If the interface has been inherited from some
+   --  ancestor then Ancestor_Typ is such node (in this case the secondary
+   --  DT is needed to handle overriden primitives); if there is no such
+   --  ancestor then  Ancestor_Typ is equal to Typ.
+   --
+   --  Internal rule followed for the generation of the external name:
+   --
+   --  Case 1. If the secondary dispatch has not been inherited from some
+   --          ancestor of Typ then the external name is composed as
+   --          follows:
+   --             External_Name (Typ) + Suffix_Number + 'P'
+   --
+   --  Case 2. if the secondary dispatch table has been inherited from some
+   --          ancestor then the external name is composed as follows:
+   --             External_Name (Typ) + '_' + External_Name (Ancestor_Typ)
+   --               + Suffix_Number + 'P'
+   --
+   --  Note: We have to use the external names (instead of simply their
+   --  names) to protect the frontend against programs that give the same
+   --  name to all the interfaces and use the expanded name to reference
+   --  them. The Suffix_Number is used to differentiate all the secondary
+   --  dispatch tables of a given type.
+   --
+   --  Examples:
+   --
+   --        package Pkg1 is | package Pkg2 is | package Pkg3 is
+   --          type Typ is   |   type Typ is   |   type Typ is
+   --            interface;  |     interface;  |     interface;
+   --        end Pkg1;       | end Pkg;        | end Pkg3;
+   --
+   --  with Pkg1, Pkg2, Pkg3;
+   --  package Case_1 is
+   --    type Typ is new Pkg1.Typ and Pkg2.Typ and Pkg3.Typ with ...
+   --  end Case_1;
+   --
+   --  with Case_1;
+   --  package Case_2 is
+   --    type Typ is new Case_1.Typ with ...
+   --  end Case_2;
+   --
+   --  These are the external names generated for Case_1.Typ (note that
+   --  Pkg1.Typ is associated with the Primary Dispatch Table, because it
+   --  is the the parent of this type, and hence no external name is
+   --  generated for it).
+   --      case_1__typ0P   (associated with Pkg2.Typ)
+   --      case_1__typ1P   (associated with Pkg3.Typ)
+   --
+   --  These are the external names generated for Case_2.Typ:
+   --      case_2__typ_case_1__typ0P
+   --      case_2__typ_case_1__typ1P
+
    ----------------------------
    -- Effect of Optimization --
    ----------------------------

gcc/ada/exp_disp.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -28,8 +28,144 @@
 --  dispatching expansion.
 
 with Types; use Types;
+
 package Exp_Disp is
 
+   -------------------------------------
+   -- Predefined primitive operations --
+   -------------------------------------
+
+   --  The predefined primitive operations (PPOs) are subprograms generated
+   --  by GNAT for a particular tagged type. Their role is to provide support
+   --  for different Ada language features such as the attribute 'Size or
+   --  handling of dispatching triggers in select statements. PPOs are created
+   --  when a tagged type is expanded or frozen. These subprograms are later
+   --  collected and inserted into the dispatch table of a tagged type at
+   --  fixed positions. Some of the PPOs that manipulate data in tagged objects
+   --  require the generation of thunks.
+
+   --  List of predefined primitive operations
+
+   --    Leading underscores designate reserved names. Bracketed numerical
+   --    values represent dispatch table slot numbers.
+
+   --      _Size (1) - implementation of the attribute 'Size for any tagged
+   --      type. Constructs of the form Prefix'Size are converted into
+   --      Prefix._Size.
+
+   --      _Alignment (2) - implementation of the attribute 'Alignment for
+   --      any tagged type. Constructs of the form Prefix'Alignment are
+   --      converted into Prefix._Alignment.
+
+   --      TSS_Stream_Read (3) - implementation of the stream attribute Read
+   --      for any tagged type.
+
+   --      TSS_Stream_Write (4) - implementation of the stream attribute Write
+   --      for any tagged type.
+
+   --      TSS_Stream_Input (5) - implementation of the stream attribute Input
+   --      for any tagged type.
+
+   --      TSS_Stream_Output (6) - implementation of the stream attribute
+   --      Output for any tagged type.
+
+   --      Op_Eq (7) - implementation of the equality operator for any non-
+   --      limited tagged type.
+
+   --      _Assign (8) - implementation of the assignment operator for any
+   --      non-limited tagged type.
+
+   --      TSS_Deep_Adjust (9) - implementation of the finalization operation
+   --      Adjust for any non-limited tagged type.
+
+   --      TSS_Deep_Finalize (10) - implementation of the finalization
+   --      operation Finalize for any non-limited tagged type.
+
+   --      _Disp_Asynchronous_Select (11) - used in the expansion of ATC with
+   --      dispatching triggers. Null implementation for limited interfaces,
+   --      full body generation for types that implement limited interfaces,
+   --      not generated for the rest of the cases. See Expand_N_Asynchronous_
+   --      Select in Exp_Ch9 for more information.
+
+   --      _Disp_Conditional_Select (12) - used in the expansion of conditional
+   --      selects with dispatching triggers. Null implementation for limited
+   --      interfaces, full body generation for types that implement limited
+   --      interfaces, not generated for the rest of the cases. See Expand_N_
+   --      Conditional_Entry_Call in Exp_Ch9 for more information.
+
+   --      _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion
+   --      of ATC with dispatching triggers. Null implementation for limited
+   --      interfaces, full body generation for types that implement limited
+   --      interfaces, not generated for the rest of the cases.
+
+   --      _Disp_Get_Task_Id (14) - helper routine used in the expansion of
+   --      Abort, attributes 'Callable and 'Terminated for task interface
+   --      class-wide types. Full body generation for task types, null
+   --      implementation for limited interfaces, not generated for the rest
+   --      of the cases. See Expand_N_Attribute_Reference in Exp_Attr and
+   --      Expand_N_Abort_Statement in Exp_Ch9 for more information.
+
+   --      _Disp_Timed_Select (15) - used in the expansion of timed selects
+   --      with dispatching triggers. Null implementation for limited
+   --      interfaces, full body generation for types that implement limited
+   --      interfaces, not generated for the rest of the cases. See Expand_N_
+   --      Timed_Entry_Call for more information.
+
+   --  Lifecycle of predefined primitive operations
+
+   --      The specifications and bodies of the PPOs are created by
+   --      Make_Predefined_Primitive_Specs and Predefined_Primitive_Bodies
+   --      in Exp_Ch3. The generated specifications are immediately analyzed,
+   --      while the bodies are left as freeze actions to the tagged type for
+   --      which they are created.
+
+   --      PPOs are collected and added to the Primitive_Operations list of
+   --      a type by the regular analysis mechanism.
+
+   --      PPOs are frozen in Predefined_Primitive_Freeze in Exp_Ch3.
+
+   --      Thunks for PPOs are created in Freeze_Subprogram in Exp_Ch6, by a
+   --      call to Register_Predefined_DT_Entry, also in Exp_Ch6.
+
+   --      Dispatch table positions of PPOs are set in Set_All_DT_Position in
+   --      Exp_Disp.
+
+   --      Calls to PPOs procede as regular dispatching calls. If the PPO
+   --      has a thunk, a call procedes as a regular dispatching call with
+   --      a thunk.
+
+   --  Guidelines for addition of new predefined primitive operations
+
+   --      Update the value of constant Default_Prim_Op_Count in Exp_Disp.ads
+   --      to reflect the new number of PPOs.
+
+   --      Update the value of constant Default_Prim_Op_Count in A-Tags.ads
+   --      to reflect the new number of PPOs. This value should be the same
+   --      as the one in Exp_Disp.ads.
+
+   --      Introduce a new predefined name for the new PPO in Snames.ads and
+   --      Snames.adb.
+
+   --      Categorize the new PPO name as predefined by adding an entry in
+   --      Is_Predefined_Dispatching_Operation in Exp_Util.adb.
+
+   --      Reserve a dispatch table position for the new PPO by adding an entry
+   --      in Default_Prim_Op_Position in Exp_Disp.adb.
+
+   --      Generate the specification of the new PPO in Make_Predefined_
+   --      Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining
+   --      identifier of the specification must be set to True.
+
+   --      Generate the body of the new PPO in Predefined_Primitive_Bodies in
+   --      Exp_Ch3.adb. The Is_Internal flag of the defining identifier of the
+   --      specification must be set to True.
+
+   --      If the new PPO requires a thunk, add an entry in Freeze_Subprogram
+   --      in Exp_Ch6.adb.
+
+   --      When generating calls to a PPO, use Find_Prim_Op from Exp_Util.ads
+   --      to retrieve the entity of the operation directly.
+
    --  Number of predefined primitive operations added by the Expander
    --  for a tagged type. If more predefined primitive operations are
    --  added, the following items must be changed:
@@ -38,7 +174,7 @@ package Exp_Disp is
    --    Exp_Disp.Default_Prim_Op_Position - indirect use
    --    Exp_Disp.Set_All_DT_Position      - direct   use
 
-   Default_Prim_Op_Count : constant Int := 14;
+   Default_Prim_Op_Count : constant Int := 15;
 
    type DT_Access_Action is
       (CW_Membership,
@@ -48,6 +184,7 @@ package Exp_Disp is
        Get_Access_Level,
        Get_Entry_Index,
        Get_External_Tag,
+       Get_Offset_Index,
        Get_Prim_Op_Address,
        Get_Prim_Op_Kind,
        Get_RC_Offset,
@@ -60,10 +197,13 @@ package Exp_Disp is
        Set_Entry_Index,
        Set_Expanded_Name,
        Set_External_Tag,
+       Set_Offset_Index,
+       Set_OSD,
        Set_Prim_Op_Address,
        Set_Prim_Op_Kind,
        Set_RC_Offset,
        Set_Remotely_Callable,
+       Set_SSD,
        Set_TSD,
        TSD_Entry_Size,
        TSD_Prologue_Size);
@@ -117,16 +257,6 @@ package Exp_Disp is
    --  Ada 2005 (AI-251): Initialize the entries associated with predefined
    --  primitives in all the secondary dispatch tables of Typ.
 
-   procedure Make_Abstract_Interface_DT
-     (AI_Tag          : Entity_Id;
-      Acc_Disp_Tables : in out Elist_Id;
-      Result          : out List_Id);
-   --  Ada 2005 (AI-251): Expand the declarations for the secondary Dispatch
-   --  Tables corresponding with an abstract interface. The reference to the
-   --  dispatch table is appended at the end of Acc_Disp_Tables; it will be
-   --  are later used to generate the corresponding initialization statement
-   --  (see Exp_Ch3.Build_Init_Procedure).
-
    function Make_DT_Access_Action
      (Typ    : Entity_Id;
       Action : DT_Access_Action;
@@ -141,7 +271,8 @@ package Exp_Disp is
    function Make_Disp_Asynchronous_Select_Body
      (Typ : Entity_Id) return Node_Id;
    --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
-   --  Typ used for dispatching in asynchronous selects.
+   --  Typ used for dispatching in asynchronous selects. Generate a null body
+   --  if Typ is an interface type.
 
    function Make_Disp_Asynchronous_Select_Spec
      (Typ : Entity_Id) return Node_Id;
@@ -151,7 +282,8 @@ package Exp_Disp is
    function Make_Disp_Conditional_Select_Body
      (Typ : Entity_Id) return Node_Id;
    --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
-   --  Typ used for dispatching in conditional selects.
+   --  Typ used for dispatching in conditional selects. Generate a null body
+   --  if Typ is an interface type.
 
    function Make_Disp_Conditional_Select_Spec
      (Typ : Entity_Id) return Node_Id;
@@ -162,7 +294,7 @@ package Exp_Disp is
      (Typ : Entity_Id) return Node_Id;
    --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
    --  Typ used for retrieving the callable entity kind during dispatching in
-   --  asynchronous selects.
+   --  asynchronous selects. Generate a null body if Typ is an interface type.
 
    function Make_Disp_Get_Prim_Op_Kind_Spec
      (Typ : Entity_Id) return Node_Id;
@@ -170,23 +302,52 @@ package Exp_Disp is
    --  of the type Typ use for retrieving the callable entity kind during
    --  dispatching in asynchronous selects.
 
-   function Make_Disp_Select_Tables
-     (Typ : Entity_Id) return List_Id;
-   --  Ada 2005 (AI-345): Populate the two auxiliary tables in the TSD of Typ
-   --  used for dispatching in asynchronous, conditional and timed selects.
-   --  Generate code to set the primitive operation kinds and entry indices
-   --  of primitive operations and primitive wrappers.
+   function Make_Disp_Get_Task_Id_Body
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
+   --  Typ used for retrieving the _task_id field of a task interface class-
+   --  wide type. Generate a null body if Typ is an interface or a non-task
+   --  type.
+
+   function Make_Disp_Get_Task_Id_Spec
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the specification of the primitive operation
+   --  of type Typ used for retrieving the _task_id field of a task interface
+   --  class-wide type.
 
    function Make_Disp_Timed_Select_Body
      (Typ : Entity_Id) return Node_Id;
    --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
-   --  Typ used for dispatching in timed selects.
+   --  Typ used for dispatching in timed selects. Generate a null body if Nul
+   --  is an interface type.
 
    function Make_Disp_Timed_Select_Spec
      (Typ : Entity_Id) return Node_Id;
    --  Ada 2005 (AI-345): Generate the specification of the primitive operation
    --  of type Typ used for dispatching in timed selects.
 
+   function Make_Select_Specific_Data_Table
+     (Typ : Entity_Id) return List_Id;
+   --  Ada 2005 (AI-345): Create and populate the auxiliary table in the TSD
+   --  of Typ used for dispatching in asynchronous, conditional and timed
+   --  selects. Generate code to set the primitive operation kinds and entry
+   --  indices of primitive operations and primitive wrappers.
+
+   procedure Make_Secondary_DT
+     (Typ             : Entity_Id;
+      Ancestor_Typ    : Entity_Id;
+      Suffix_Index    : Int;
+      Iface           : Entity_Id;
+      AI_Tag          : Entity_Id;
+      Acc_Disp_Tables : in out Elist_Id;
+      Result          : out List_Id);
+   --  Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
+   --  Table of Typ associated with Iface (each abstract interface implemented
+   --  by Typ has a secondary dispatch table). The arguments Typ, Ancestor_Typ
+   --  and Suffix_Index are used to generate an unique external name which
+   --  is added at the end of Acc_Disp_Tables; this external name will be
+   --  used later by the subprogram Exp_Ch3.Build_Init_Procedure.
+
    procedure Set_All_DT_Position (Typ : Entity_Id);
    --  Set the DT_Position field for each primitive operation. In the CPP
    --  Class case check that no pragma CPP_Virtual is missing and that the

gcc/ada/exp_util.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -1275,6 +1275,16 @@ package body Exp_Util is
       then
          null;
 
+      --  Nothing to be done for derived types with unknown discriminants if
+      --  the parent type also has unknown discriminants.
+
+      elsif Is_Record_Type (Unc_Type)
+        and then not Is_Class_Wide_Type (Unc_Type)
+        and then Has_Unknown_Discriminants (Unc_Type)
+        and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
+      then
+         null;
+
       --  Nothing to be done if the type of the expression is limited, because
       --  in this case the expression cannot be copied, and its use can only
       --  be by reference and there is no need for the actual subtype.
@@ -1289,8 +1299,147 @@ package body Exp_Util is
       end if;
    end Expand_Subtype_From_Expr;
 
+   --------------------------------
+   -- Find_Implemented_Interface --
+   --------------------------------
+
+   --  Given the following code (XXX denotes irrelevant value):
+
+   --     type Limd_Iface is limited interface;
+   --     type Prot_Iface is protected interface;
+   --     type Sync_Iface is synchronized interface;
+
+   --     type Parent_Subtype is new Limd_Iface and Sync_Iface with ...
+   --     type Child_Subtype is new Parent_Subtype and Prot_Iface with ...
+
+   --  The following calls will return the following values:
+
+   --     Find_Implemented_Interface
+   --       (Child_Subtype, Synchronized_Interface, False)    -> Empty
+
+   --     Find_Implemented_Interface
+   --       (Child_Subtype, Synchronized_Interface, True)     -> Sync_Iface
+
+   --     Find_Implemented_Interface
+   --       (Child_Subtype, Any_Synchronized_Interface, XXX)  -> Prot_Iface
+
+   --     Find_Implemented_Interface
+   --       (Child_Subtype, Any_Limited_Interface, XXX)       -> Prot_Iface
+
+   function Find_Implemented_Interface
+     (Typ          : Entity_Id;
+      Kind         : Interface_Kind;
+      Check_Parent : Boolean := False) return Entity_Id
+   is
+      Iface_Elmt : Elmt_Id;
+
+      function Interface_In_Kind
+        (I    : Entity_Id;
+         Kind : Interface_Kind) return Boolean;
+      --  Determine whether an interface falls into a specified kind
+
+      -----------------------
+      -- Interface_In_Kind --
+      -----------------------
+
+      function Interface_In_Kind
+        (I    : Entity_Id;
+         Kind : Interface_Kind) return Boolean is
+      begin
+         if Is_Limited_Interface (I)
+           and then (Kind = Any_Interface
+             or else Kind = Any_Limited_Interface
+             or else Kind = Limited_Interface)
+         then
+            return True;
+
+         elsif Is_Protected_Interface (I)
+           and then (Kind = Any_Interface
+             or else Kind = Any_Limited_Interface
+             or else Kind = Any_Synchronized_Interface
+             or else Kind = Protected_Interface)
+         then
+            return True;
+
+         elsif Is_Synchronized_Interface (I)
+           and then (Kind = Any_Interface
+             or else Kind = Any_Limited_Interface
+             or else Kind = Synchronized_Interface)
+         then
+            return True;
+
+         elsif Is_Task_Interface (I)
+           and then (Kind = Any_Interface
+             or else Kind = Any_Limited_Interface
+             or else Kind = Any_Synchronized_Interface
+             or else Kind = Task_Interface)
+         then
+            return True;
+
+         --  Regular interface. This should be the last kind to check since
+         --  all of the previous cases have their Is_Interface flags set.
+
+         elsif Is_Interface (I)
+           and then (Kind = Any_Interface
+             or else Kind = Iface)
+         then
+            return True;
+
+         else
+            return False;
+         end if;
+      end Interface_In_Kind;
+
+   --  Start of processing for Find_Implemented_Interface
+
+   begin
+      if not Is_Tagged_Type (Typ) then
+         return Empty;
+      end if;
+
+      --  Implementations of the form:
+      --    Typ is new Interface ...
+
+      if Is_Interface (Etype (Typ))
+        and then Interface_In_Kind (Etype (Typ), Kind)
+      then
+         return Etype (Typ);
+      end if;
+
+      --  Implementations of the form:
+      --     Typ is new Typ_Parent and Interface ...
+
+      if Present (Abstract_Interfaces (Typ)) then
+         Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+         while Present (Iface_Elmt) loop
+            if Interface_In_Kind (Node (Iface_Elmt), Kind) then
+               return Node (Iface_Elmt);
+            end if;
+
+            Iface_Elmt := Next_Elmt (Iface_Elmt);
+         end loop;
+      end if;
+
+      --  Typ is a derived type and may implement a limited interface
+      --  through its parent subtype. Check the parent subtype as well
+      --  as any interfaces explicitly implemented at this level.
+
+      if Check_Parent
+        and then Ekind (Typ) = E_Record_Type
+        and then Present (Parent_Subtype (Typ))
+      then
+         return Find_Implemented_Interface (
+           Parent_Subtype (Typ), Kind, Check_Parent);
+      end if;
+
+      --  Typ does not implement a limited interface either at this level or
+      --  in any of its parent subtypes.
+
+      return Empty;
+   end Find_Implemented_Interface;
+
    ------------------------
-   -- Find_Interface_Tag --
+   -- Find_Interface_ADT --
    ------------------------
 
    function Find_Interface_ADT
@@ -1302,7 +1451,7 @@ package body Exp_Util is
       Typ   : Entity_Id := T;
 
       procedure Find_Secondary_Table (Typ : Entity_Id);
-      --  Comment required ???
+      --  Internal subprogram used to recursively climb to the ancestors
 
       --------------------------
       -- Find_Secondary_Table --
@@ -1313,10 +1462,23 @@ package body Exp_Util is
          AI      : Node_Id;
 
       begin
-         if Etype (Typ) /= Typ then
+         --  Climb to the ancestor (if any) handling private types
+
+         if Present (Full_View (Etype (Typ))) then
+            if Full_View (Etype (Typ)) /= Typ then
+               Find_Secondary_Table (Full_View (Etype (Typ)));
+            end if;
+
+         elsif Etype (Typ) /= Typ then
             Find_Secondary_Table (Etype (Typ));
          end if;
 
+         --  If we already found it there is nothing else to do
+
+         if Found then
+            return;
+         end if;
+
          if Present (Abstract_Interfaces (Typ))
            and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
          then
@@ -1401,9 +1563,14 @@ package body Exp_Util is
             return;
          end if;
 
-         --  Climb to the root type
+         --  Climb to the root type handling private types
+
+         if Present (Full_View (Etype (Typ))) then
+            if Full_View (Etype (Typ)) /= Typ then
+               Find_Tag (Full_View (Etype (Typ)));
+            end if;
 
-         if Etype (Typ) /= Typ then
+         elsif Etype (Typ) /= Typ then
             Find_Tag (Etype (Typ));
          end if;
 
@@ -1437,6 +1604,8 @@ package body Exp_Util is
    --  Start of processing for Find_Interface_Tag
 
    begin
+      pragma Assert (Is_Interface (Iface));
+
       --  Handle private types
 
       if Has_Private_Declaration (Typ)
@@ -1742,67 +1911,17 @@ package body Exp_Util is
       return Count;
    end Homonym_Number;
 
-   ----------------------------------
-   -- Implements_Limited_Interface --
-   ----------------------------------
-
-   function Implements_Limited_Interface (Typ : Entity_Id) return Boolean is
-      function Contains_Limited_Interface
-        (Ifaces : Elist_Id) return Boolean;
-      --  Given a list of interfaces, determine whether one of them is limited
-
-      --------------------------------
-      -- Contains_Limited_Interface --
-      --------------------------------
-
-      function Contains_Limited_Interface
-        (Ifaces : Elist_Id) return Boolean
-      is
-         Iface_Elmt : Elmt_Id;
-
-      begin
-         if not Present (Ifaces) then
-            return False;
-         end if;
-
-         Iface_Elmt := First_Elmt (Ifaces);
-
-         while Present (Iface_Elmt) loop
-            if Is_Limited_Record (Node (Iface_Elmt)) then
-               return True;
-            end if;
-
-            Iface_Elmt := Next_Elmt (Iface_Elmt);
-         end loop;
-
-         return False;
-      end Contains_Limited_Interface;
-
-   --  Start of processing for Implements_Limited_Interface
+   --------------------------
+   -- Implements_Interface --
+   --------------------------
 
+   function Implements_Interface
+     (Typ          : Entity_Id;
+      Kind         : Interface_Kind;
+      Check_Parent : Boolean := False) return Boolean is
    begin
-      --  Typ is a derived type and may implement a limited interface
-      --  through its parent subtype. Check the parent subtype as well
-      --  as any interfaces explicitly implemented at this level.
-
-      if Ekind (Typ) = E_Record_Type
-        and then Present (Parent_Subtype (Typ))
-      then
-         return Contains_Limited_Interface (Abstract_Interfaces (Typ))
-           or else Implements_Limited_Interface (Parent_Subtype (Typ));
-
-      --  Typ is an abstract type derived from some interface
-
-      elsif Is_Abstract (Typ) then
-         return Is_Interface (Etype (Typ))
-           and then Is_Limited_Record (Etype (Typ));
-
-      --  Typ may directly implement some interface
-
-      else
-         return Contains_Limited_Interface (Abstract_Interfaces (Typ));
-      end if;
-   end Implements_Limited_Interface;
+      return Find_Implemented_Interface (Typ, Kind, Check_Parent) /= Empty;
+   end Implements_Interface;
 
    ------------------------------
    -- In_Unconditional_Context --
@@ -2436,7 +2555,6 @@ package body Exp_Util is
       if Suppress = All_Checks then
          declare
             Svg : constant Suppress_Array := Scope_Suppress;
-
          begin
             Scope_Suppress := (others => True);
             Insert_Actions (Assoc_Node, Ins_Actions);
@@ -2446,7 +2564,6 @@ package body Exp_Util is
       else
          declare
             Svg : constant Boolean := Scope_Suppress (Suppress);
-
          begin
             Scope_Suppress (Suppress) := True;
             Insert_Actions (Assoc_Node, Ins_Actions);
@@ -2557,9 +2674,9 @@ package body Exp_Util is
       return True;
    end Is_All_Null_Statements;
 
-   ------------------------
-   -- Is_Default_Prim_Op --
-   ------------------------
+   -----------------------------------------
+   -- Is_Predefined_Dispatching_Operation --
+   -----------------------------------------
 
    function Is_Predefined_Dispatching_Operation
      (Subp : Entity_Id) return Boolean
@@ -2590,10 +2707,12 @@ package body Exp_Util is
            or else Chars (E) = Name_uAssign
            or else TSS_Name  = TSS_Deep_Adjust
            or else TSS_Name  = TSS_Deep_Finalize
-           or else Chars (E) = Name_uDisp_Asynchronous_Select
+           or else (Ada_Version >= Ada_05
+             and then (Chars (E) = Name_uDisp_Asynchronous_Select
                or else Chars (E) = Name_uDisp_Conditional_Select
                or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
-           or else Chars (E) = Name_uDisp_Timed_Select
+               or else Chars (E) = Name_uDisp_Get_Task_Id
+               or else Chars (E) = Name_uDisp_Timed_Select))
          then
             return True;
          end if;
@@ -3466,7 +3585,7 @@ package body Exp_Util is
             return New_Occurrence_Of (CW_Subtype, Loc);
          end;
 
-      --  Comment needed (what case is this ???)
+      --  Indefinite record type with discriminants.
 
       else
          D := First_Discriminant (Unc_Typ);

gcc/ada/exp_util.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -33,6 +33,21 @@ with Types;   use Types;
 
 package Exp_Util is
 
+   --  An enumeration type used to capture all the possible interface
+   --  kinds and their hierarchical relation. These values are used in
+   --  Find_Implemented_Interface and Implements_Interface.
+
+   type Interface_Kind is (
+     Any_Interface,               --  Any interface
+     Any_Limited_Interface,       --  Only limited interfaces
+     Any_Synchronized_Interface,  --  Only synchronized interfaces
+
+     Iface,                       --  Individual kinds
+     Limited_Interface,
+     Protected_Interface,
+     Synchronized_Interface,
+     Task_Interface);
+
    -----------------------------------------------
    -- Handling of Actions Associated with Nodes --
    -----------------------------------------------
@@ -336,6 +351,16 @@ package Exp_Util is
    --  Ada 2005 (AI-251): Given a type T implementing the interface Iface,
    --  return the record component containing the tag of Iface.
 
+   function Find_Implemented_Interface
+     (Typ          : Entity_Id;
+      Kind         : Interface_Kind;
+      Check_Parent : Boolean := False) return Entity_Id;
+   --  Ada 2005 (AI-345): Find a designated kind of interface implemented by
+   --  Typ or any parent subtype. Return the first encountered interface that
+   --  correspond to the selected class. Return Empty if no such interface is
+   --  found. Use Check_Parent to climb a potential derivation chain and
+   --  examine the parent subtypes for any implementation.
+
    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
    --  Find the first primitive operation of type T whose name is 'Name'.
    --  This function allows the use of a primitive operation which is not
@@ -410,11 +435,13 @@ package Exp_Util is
    --  chain, counting only entries in the curren scope. If an entity is not
    --  overloaded, the returned number will be one.
 
-   function Implements_Limited_Interface (Typ : Entity_Id) return Boolean;
-   --  Ada 2005 (AI-345): Determine whether Typ implements some limited
-   --  interface. The interface may be of limited, protected, synchronized
-   --  or taks kind. Typ may also be derived from a type that implements a
-   --  limited interface.
+   function Implements_Interface
+     (Typ          : Entity_Id;
+      Kind         : Interface_Kind;
+      Check_Parent : Boolean := False) return Boolean;
+   --  Ada 2005 (AI-345): Determine whether Typ implements a designated kind
+   --  of interface. Use Check_Parent to climb a potential derivation chain
+   --  and examine the parent subtypes for any implementation.
 
    function Inside_Init_Proc return Boolean;
    --  Returns True if current scope is within an init proc

gcc/ada/rtsfind.ads

@@ -209,9 +209,14 @@ package Rtsfind is
       System_Exp_Mod,
       System_Exp_Uns,
       System_Fat_Flt,
+      System_Fat_IEEE_Long_Float,
+      System_Fat_IEEE_Short_Float,
       System_Fat_LFlt,
       System_Fat_LLF,
       System_Fat_SFlt,
+      System_Fat_VAX_D_Float,
+      System_Fat_VAX_F_Float,
+      System_Fat_VAX_G_Float,
       System_Finalization_Implementation,
       System_Finalization_Root,
       System_Fore,
@@ -493,6 +498,7 @@ package Rtsfind is
      RE_Get_Access_Level,                -- Ada.Tags
      RE_Get_Entry_Index,                 -- Ada.Tags
      RE_Get_External_Tag,                -- Ada.Tags
+     RE_Get_Offset_Index,                -- Ada.Tags
      RE_Get_Prim_Op_Address,             -- Ada.Tags
      RE_Get_Prim_Op_Kind,                -- Ada.Tags
      RE_Get_RC_Offset,                   -- Ada.Tags
@@ -501,25 +507,32 @@ package Rtsfind is
      RE_Inherit_TSD,                     -- Ada.Tags
      RE_Internal_Tag,                    -- Ada.Tags
      RE_Is_Descendant_At_Same_Level,     -- Ada.Tags
+     RE_Object_Specific_Data,            -- Ada.Tags
      RE_POK_Function,                    -- Ada.Tags
      RE_POK_Procedure,                   -- Ada.Tags
      RE_POK_Protected_Entry,             -- Ada.Tags
      RE_POK_Protected_Function,          -- Ada.Tags
      RE_POK_Protected_Procedure,         -- Ada.Tags
      RE_POK_Task_Entry,                  -- Ada.Tags
+     RE_POK_Task_Function,               -- Ada.Tags
      RE_POK_Task_Procedure,              -- Ada.Tags
      RE_Prim_Op_Kind,                    -- Ada.Tags
      RE_Register_Interface_Tag,          -- Ada.Tags
      RE_Register_Tag,                    -- Ada.Tags
+     RE_Select_Specific_Data,            -- Ada.Tags
      RE_Set_Access_Level,                -- Ada.Tags
      RE_Set_Entry_Index,                 -- Ada.Tags
      RE_Set_Expanded_Name,               -- Ada.Tags
      RE_Set_External_Tag,                -- Ada.Tags
+     RE_Set_Num_Prim_Ops,                -- Ada.Tags
+     RE_Set_Offset_Index,                -- Ada.Tags
      RE_Set_Offset_To_Top,               -- Ada.Tags
+     RE_Set_OSD,                         -- Ada.Tags
      RE_Set_Prim_Op_Address,             -- Ada.Tags
      RE_Set_Prim_Op_Kind,                -- Ada.Tags
      RE_Set_RC_Offset,                   -- Ada.Tags
      RE_Set_Remotely_Callable,           -- Ada.Tags
+     RE_Set_SSD,                         -- Ada.Tags
      RE_Set_TSD,                         -- Ada.Tags
      RE_Tag_Error,                       -- Ada.Tags
      RE_TSD_Entry_Size,                  -- Ada.Tags
@@ -527,6 +540,10 @@ package Rtsfind is
      RE_Interface_Tag,                   -- Ada.Tags
      RE_Tag,                             -- Ada.Tags
      RE_Address_Array,                   -- Ada.Tags
+     RE_Valid_Signature,                 -- Ada.Tags
+     RE_Primary_DT,                      -- Ada.Tags
+     RE_Secondary_DT,                    -- Ada.Tags
+     RE_Abstract_Interface,              -- Ada.Tags
 
      RE_Abort_Task,                      -- Ada.Task_Identification
      RE_Current_Task,                    -- Ada.Task_Identification
@@ -666,13 +683,28 @@ package Rtsfind is
 
      RE_Exp_Unsigned,                    -- System.Exp_Uns
 
-     RE_Fat_Float,                       -- System.Fat_Flt
+     RE_Attr_Float,                      -- System.Fat_Flt
 
-     RE_Fat_Long_Float,                  -- System.Fat_LFlt
+     RE_Attr_IEEE_Long,                  -- System.Fat_IEEE_Long_Float
+     RE_Fat_IEEE_Long,                   -- System.Fat_IEEE_Long_Float
 
-     RE_Fat_Long_Long_Float,             -- System.Fat_LLF
+     RE_Attr_IEEE_Short,                 -- System.Fat_IEEE_Short_Float
+     RE_Fat_IEEE_Short,                  -- System.Fat_IEEE_Short_Float
 
-     RE_Fat_Short_Float,                 -- System.Fat_SFlt
+     RE_Attr_Long_Float,                 -- System.Fat_LFlt
+
+     RE_Attr_Long_Long_Float,            -- System.Fat_LLF
+
+     RE_Attr_Short_Float,                -- System.Fat_SFlt
+
+     RE_Attr_VAX_D_Float,                -- System.Fat_VAX_D_Float
+     RE_Fat_VAX_D,                       -- System.Fat_VAX_D_Float
+
+     RE_Attr_VAX_F_Float,                -- System.Fat_VAX_F_Float
+     RE_Fat_VAX_F,                       -- System.Fat_VAX_F_Float
+
+     RE_Attr_VAX_G_Float,                -- System.Fat_VAX_G_Float
+     RE_Fat_VAX_G,                       -- System.Fat_VAX_G_Float
 
      RE_Attach_To_Final_List,            -- System.Finalization_Implementation
      RE_Finalize_List,                   -- System.Finalization_Implementation
@@ -1151,6 +1183,7 @@ package Rtsfind is
 
      RE_TC_Alias,                        -- System.PolyORB_Interface
      RE_TC_Build,                        -- System.PolyORB_Interface
+     RE_Get_TC,                          -- System.PolyORB_Interface
      RE_Set_TC,                          -- System.PolyORB_Interface
      RE_TC_Any,                          -- System.PolyORB_Interface
      RE_TC_AD,                           -- System.PolyORB_Interface
@@ -1219,6 +1252,7 @@ package Rtsfind is
      RE_Integer_Address,                 -- System.Storage_Elements
      RE_Storage_Offset,                  -- System.Storage_Elements
      RE_Storage_Array,                   -- System.Storage_Elements
+     RE_Storage_Element,                 -- System.Storage_Elements
      RE_To_Address,                      -- System.Storage_Elements
 
      RE_Root_Storage_Pool,               -- System.Storage_Pools
@@ -1291,6 +1325,7 @@ package Rtsfind is
      RE_Task_Procedure_Access,           -- System.Tasking
 
      RO_ST_Task_Id,                      -- System.Tasking
+     RO_ST_Null_Task,                    -- System.Tasking
 
      RE_Call_Modes,                      -- System.Tasking
      RE_Simple_Call,                     -- System.Tasking
@@ -1417,6 +1452,8 @@ package Rtsfind is
      RE_Le_G,                            -- System.Vax_Float_Operations
      RE_Lt_F,                            -- System.Vax_Float_Operations
      RE_Lt_G,                            -- System.Vax_Float_Operations
+     RE_Ne_F,                            -- System.Vax_Float_Operations
+     RE_Ne_G,                            -- System.Vax_Float_Operations
 
      RE_Valid_D,                         -- System.Vax_Float_Operations
      RE_Valid_F,                         -- System.Vax_Float_Operations
@@ -1602,6 +1639,7 @@ package Rtsfind is
      RE_Get_Access_Level                 => Ada_Tags,
      RE_Get_Entry_Index                  => Ada_Tags,
      RE_Get_External_Tag                 => Ada_Tags,
+     RE_Get_Offset_Index                 => Ada_Tags,
      RE_Get_Prim_Op_Address              => Ada_Tags,
      RE_Get_Prim_Op_Kind                 => Ada_Tags,
      RE_Get_RC_Offset                    => Ada_Tags,
@@ -1610,25 +1648,32 @@ package Rtsfind is
      RE_Inherit_TSD                      => Ada_Tags,
      RE_Internal_Tag                     => Ada_Tags,
      RE_Is_Descendant_At_Same_Level      => Ada_Tags,
+     RE_Object_Specific_Data             => Ada_Tags,
      RE_POK_Function                     => Ada_Tags,
      RE_POK_Procedure                    => Ada_Tags,
      RE_POK_Protected_Entry              => Ada_Tags,
      RE_POK_Protected_Function           => Ada_Tags,
      RE_POK_Protected_Procedure          => Ada_Tags,
      RE_POK_Task_Entry                   => Ada_Tags,
+     RE_POK_Task_Function                => Ada_Tags,
      RE_POK_Task_Procedure               => Ada_Tags,
      RE_Prim_Op_Kind                     => Ada_Tags,
      RE_Register_Interface_Tag           => Ada_Tags,
      RE_Register_Tag                     => Ada_Tags,
+     RE_Select_Specific_Data             => Ada_Tags,
      RE_Set_Access_Level                 => Ada_Tags,
      RE_Set_Entry_Index                  => Ada_Tags,
      RE_Set_Expanded_Name                => Ada_Tags,
      RE_Set_External_Tag                 => Ada_Tags,
+     RE_Set_Num_Prim_Ops                 => Ada_Tags,
+     RE_Set_Offset_Index                 => Ada_Tags,
      RE_Set_Offset_To_Top                => Ada_Tags,
+     RE_Set_OSD                          => Ada_Tags,
      RE_Set_Prim_Op_Address              => Ada_Tags,
      RE_Set_Prim_Op_Kind                 => Ada_Tags,
      RE_Set_RC_Offset                    => Ada_Tags,
      RE_Set_Remotely_Callable            => Ada_Tags,
+     RE_Set_SSD                          => Ada_Tags,
      RE_Set_TSD                          => Ada_Tags,
      RE_Tag_Error                        => Ada_Tags,
      RE_TSD_Entry_Size                   => Ada_Tags,
@@ -1636,6 +1681,10 @@ package Rtsfind is
      RE_Interface_Tag                    => Ada_Tags,
      RE_Tag                              => Ada_Tags,
      RE_Address_Array                    => Ada_Tags,
+     RE_Valid_Signature                  => Ada_Tags,
+     RE_Primary_DT                       => Ada_Tags,
+     RE_Secondary_DT                     => Ada_Tags,
+     RE_Abstract_Interface               => Ada_Tags,
 
      RE_Abort_Task                       => Ada_Task_Identification,
      RE_Current_Task                     => Ada_Task_Identification,
@@ -1773,13 +1822,28 @@ package Rtsfind is
 
      RE_Exp_Unsigned                     => System_Exp_Uns,
 
-     RE_Fat_Float                        => System_Fat_Flt,
+     RE_Attr_Float                       => System_Fat_Flt,
+
+     RE_Attr_IEEE_Long                   => System_Fat_IEEE_Long_Float,
+     RE_Fat_IEEE_Long                    => System_Fat_IEEE_Long_Float,
+
+     RE_Attr_IEEE_Short                  => System_Fat_IEEE_Short_Float,
+     RE_Fat_IEEE_Short                   => System_Fat_IEEE_Short_Float,
+
+     RE_Attr_Long_Float                  => System_Fat_LFlt,
+
+     RE_Attr_Long_Long_Float             => System_Fat_LLF,
+
+     RE_Attr_Short_Float                 => System_Fat_SFlt,
 
-     RE_Fat_Long_Float                   => System_Fat_LFlt,
+     RE_Attr_VAX_D_Float                 => System_Fat_VAX_D_Float,
+     RE_Fat_VAX_D                        => System_Fat_VAX_D_Float,
 
-     RE_Fat_Long_Long_Float              => System_Fat_LLF,
+     RE_Attr_VAX_F_Float                 => System_Fat_VAX_F_Float,
+     RE_Fat_VAX_F                        => System_Fat_VAX_F_Float,
 
-     RE_Fat_Short_Float                  => System_Fat_SFlt,
+     RE_Attr_VAX_G_Float                 => System_Fat_VAX_G_Float,
+     RE_Fat_VAX_G                        => System_Fat_VAX_G_Float,
 
      RE_Attach_To_Final_List             => System_Finalization_Implementation,
      RE_Finalize_List                    => System_Finalization_Implementation,
@@ -2249,6 +2313,7 @@ package Rtsfind is
 
      RE_TC_Alias                         => System_PolyORB_Interface,
      RE_TC_Build                         => System_PolyORB_Interface,
+     RE_Get_TC                           => System_PolyORB_Interface,
      RE_Set_TC                           => System_PolyORB_Interface,
      RE_TC_Any                           => System_PolyORB_Interface,
      RE_TC_AD                            => System_PolyORB_Interface,
@@ -2326,6 +2391,7 @@ package Rtsfind is
      RE_Integer_Address                  => System_Storage_Elements,
      RE_Storage_Offset                   => System_Storage_Elements,
      RE_Storage_Array                    => System_Storage_Elements,
+     RE_Storage_Element                  => System_Storage_Elements,
      RE_To_Address                       => System_Storage_Elements,
 
      RE_Root_Storage_Pool                => System_Storage_Pools,
@@ -2397,6 +2463,7 @@ package Rtsfind is
      RE_Task_Procedure_Access            => System_Tasking,
 
      RO_ST_Task_Id                       => System_Tasking,
+     RO_ST_Null_Task                     => System_Tasking,
 
      RE_Call_Modes                       => System_Tasking,
      RE_Simple_Call                      => System_Tasking,
@@ -2523,6 +2590,8 @@ package Rtsfind is
      RE_Le_G                             => System_Vax_Float_Operations,
      RE_Lt_F                             => System_Vax_Float_Operations,
      RE_Lt_G                             => System_Vax_Float_Operations,
+     RE_Ne_F                             => System_Vax_Float_Operations,
+     RE_Ne_G                             => System_Vax_Float_Operations,
 
      RE_Valid_D                          => System_Vax_Float_Operations,
      RE_Valid_F                          => System_Vax_Float_Operations,

gcc/ada/sem_ch9.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -28,7 +28,7 @@ with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
-with Exp_Ch9;
+with Exp_Ch9;  use Exp_Ch9;
 with Elists;   use Elists;
 with Freeze;   use Freeze;
 with Itypes;   use Itypes;
@@ -94,11 +94,22 @@ package body Sem_Ch9 is
       while Present (T_Name) loop
          Analyze (T_Name);
 
-         if not Is_Task_Type (Etype (T_Name)) then
+         if Is_Task_Type (Etype (T_Name))
+           or else (Ada_Version >= Ada_05
+                      and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
+                      and then Is_Interface (Etype (T_Name))
+                      and then Is_Task_Interface (Etype (T_Name)))
+         then
+            Resolve (T_Name);
+         else
+            if Ada_Version >= Ada_05 then
+               Error_Msg_N ("expect task name or task interface class-wide "
+                          & "object for ABORT", T_Name);
+            else
                Error_Msg_N ("expect task name for ABORT", T_Name);
+            end if;
+
             return;
-         else
-            Resolve (T_Name);
          end if;
 
          Next (T_Name);
@@ -298,9 +309,7 @@ package body Sem_Ch9 is
 
          begin
             E1 := First_Entity (Current_Scope);
-
             while Present (E1) loop
-
                if Ekind (E1) = E_Procedure
                  and then Chars (E1) = Chars (Entry_Nam)
                  and then Type_Conformant (E1, Entry_Nam)
@@ -368,7 +377,6 @@ package body Sem_Ch9 is
 
          begin
             Decl := First (Declarations (N));
-
             while Present (Decl) loop
                Analyze (Decl);
 
@@ -390,6 +398,7 @@ package body Sem_Ch9 is
       --  In the case of a select alternative of a selective accept,
       --  the expander references the address declaration even if there
       --  is no statement list.
+
       --  We also need to create the renaming declarations for the local
       --  variables that will replace references to the formals within
       --  the accept.
@@ -440,14 +449,49 @@ package body Sem_Ch9 is
    ---------------------------------
 
    procedure Analyze_Asynchronous_Select (N : Node_Id) is
+      Param   : Node_Id;
+      Trigger : Node_Id;
+
    begin
       Tasking_Used := True;
       Check_Restriction (Max_Asynchronous_Select_Nesting, N);
       Check_Restriction (No_Select_Statements, N);
 
-      --  Analyze the statements. We analyze statements in the abortable part
-      --  first, because this is the section that is executed first, and that
-      --  way our remembering of saved values and checks is accurate.
+      if Ada_Version >= Ada_05 then
+         Trigger := Triggering_Statement (Triggering_Alternative (N));
+
+         Analyze (Trigger);
+
+         --  The trigger is a dispatching procedure. Postpone the analysis
+         --  of the triggering and abortable statements until the expansion
+         --  of this asynchronous select in Expand_N_Asynchronous_Select.
+         --  This action is required since the code replication in Expand-
+         --  _N_Asynchronous_Select of an already analyzed statement list
+         --  causes Gigi aborts.
+
+         if Expander_Active
+           and then Nkind (Trigger) = N_Procedure_Call_Statement
+           and then Present (Parameter_Associations (Trigger))
+         then
+            Param := First (Parameter_Associations (Trigger));
+
+            if Is_Controlling_Actual (Param)
+              and then Is_Interface (Etype (Param))
+            then
+               if Is_Limited_Record (Etype (Param)) then
+                  return;
+               else
+                  Error_Msg_N
+                   ("dispatching operation of limited or synchronized " &
+                    "interface required ('R'M 9.7.2(3))!", N);
+               end if;
+            end if;
+         end if;
+      end if;
+
+      --  Analyze the statements. We analyze statements in the abortable part,
+      --  because this is the section that is executed first, and that way our
+      --  remembering of saved values and checks is accurate.
 
       Analyze_Statements (Statements (Abortable_Part (N)));
       Analyze (Triggering_Alternative (N));
@@ -462,6 +506,16 @@ package body Sem_Ch9 is
       Check_Restriction (No_Select_Statements, N);
       Tasking_Used := True;
       Analyze (Entry_Call_Alternative (N));
+
+      if List_Length (Else_Statements (N)) = 1
+        and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
+      then
+         Error_Msg_N
+           ("suspicious form of conditional entry call?", N);
+         Error_Msg_N
+           ("\`SELECT OR` may be intended rather than `SELECT ELSE`", N);
+      end if;
+
       Analyze_Statements (Else_Statements (N));
    end Analyze_Conditional_Entry_Call;
 
@@ -491,19 +545,19 @@ package body Sem_Ch9 is
 
          if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
             Pre_Analyze_And_Resolve (Expr, Standard_Duration);
-
          else
             Pre_Analyze_And_Resolve (Expr);
          end if;
 
-         if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then
-            not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time)     and then
-            not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
+         if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
+           and then not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time)
+           and then not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
          then
             Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
          end if;
 
          Check_Restriction (No_Fixed_Point, Expr);
+
       else
          Analyze (Delay_Statement (N));
       end if;
@@ -632,7 +686,13 @@ package body Sem_Ch9 is
                      then
                         Set_Etype (Def, Empty);
                         Set_Analyzed (Def, False);
-                        Set_Discrete_Subtype_Definition (Index_Spec, Def);
+
+                        --  Keep the original subtree to ensure tree is
+                        --  properly formed (e.g. for ASIS use)
+
+                        Rewrite
+                          (Discrete_Subtype_Definition (Index_Spec), Def);
+
                         Set_Analyzed (Low_Bound (Def), False);
                         Set_Analyzed (High_Bound (Def), False);
 
@@ -683,12 +743,16 @@ package body Sem_Ch9 is
       --  The entity for the protected subprogram corresponding to the entry
       --  has been created. We retain the name of this entity in the entry
       --  body, for use when the corresponding subprogram body is created.
-      --  Note that entry bodies have to corresponding_spec, and there is no
+      --  Note that entry bodies have no corresponding_spec, and there is no
       --  easy link back in the tree between the entry body and the entity for
-      --  the entry itself.
+      --  the entry itself, which is why we must propagate some attributes
+      --  explicitly from spec to body.
+
+      Set_Protected_Body_Subprogram
+        (Id, Protected_Body_Subprogram (Entry_Name));
 
-      Set_Protected_Body_Subprogram (Id,
-        Protected_Body_Subprogram (Entry_Name));
+      Set_Entry_Parameters_Type
+        (Id, Entry_Parameters_Type (Entry_Name));
 
       if Present (Decls) then
          Analyze_Declarations (Decls);
@@ -707,6 +771,9 @@ package body Sem_Ch9 is
 
       --  At the same time, we set the flags on the spec entities to suppress
       --  any warnings on the spec formals, since we also scan the spec.
+      --  Finally, we propagate the Entry_Component attribute to the body
+      --  formals, for use in the renaming declarations created later for the
+      --  formals (see exp_ch9.Add_Formal_Renamings).
 
       declare
          E1  : Entity_Id;
@@ -736,6 +803,7 @@ package body Sem_Ch9 is
 
             Set_Referenced (E2, Referenced (E1));
             Set_Referenced (E1);
+            Set_Entry_Component (E2, Entry_Component (E1));
 
          <<Continue>>
             Next_Entity (E1);
@@ -1011,9 +1079,7 @@ package body Sem_Ch9 is
       end if;
 
       E := First_Entity (Current_Scope);
-
       while Present (E) loop
-
          if Ekind (E) = E_Function
            or else Ekind (E) = E_Procedure
          then
@@ -1072,8 +1138,9 @@ package body Sem_Ch9 is
       --  Ada 2005 (AI-345)
 
       if Present (Interface_List (N)) then
-         Iface := First (Interface_List (N));
+         Set_Is_Tagged_Type (T);
 
+         Iface := First (Interface_List (N));
          while Present (Iface) loop
             Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
             Iface_Def := Type_Definition (Parent (Iface_Typ));
@@ -1147,7 +1214,6 @@ package body Sem_Ch9 is
       --  illegal uses. Now it can be set correctly.
 
       E := First_Entity (Current_Scope);
-
       while Present (E) loop
          if Ekind (E) = E_Void then
             Set_Ekind (E, E_Component);
@@ -1254,14 +1320,13 @@ package body Sem_Ch9 is
       --  Overloaded case, find right interpretation
 
       if Is_Overloaded (Entry_Name) then
-         Get_First_Interp (Entry_Name, I, It);
          Entry_Id := Empty;
 
+         Get_First_Interp (Entry_Name, I, It);
          while Present (It.Nam) loop
             if No (First_Formal (It.Nam))
               or else Subtype_Conformant (Enclosing, It.Nam)
             then
-
                --  Ada 2005 (AI-345): Since protected and task types have
                --  primitive entry wrappers, we only consider source entries.
 
@@ -1348,9 +1413,10 @@ package body Sem_Ch9 is
             --  Processing for parameters accessed by the requeue
 
             declare
-               Ent : Entity_Id := First_Formal (Enclosing);
+               Ent : Entity_Id;
 
             begin
+               Ent := First_Formal (Enclosing);
                while Present (Ent) loop
 
                   --  For OUT or IN OUT parameter, the effect of the requeue
@@ -1399,6 +1465,8 @@ package body Sem_Ch9 is
       Check_Restriction (No_Select_Statements, N);
       Tasking_Used := True;
 
+      --  Loop to analyze alternatives
+
       Alt := First (Alts);
       while Present (Alt) loop
          Alt_Count := Alt_Count + 1;
@@ -1716,7 +1784,6 @@ package body Sem_Ch9 is
 
       begin
          Ent := First_Entity (Spec_Id);
-
          while Present (Ent) loop
             if Is_Entry (Ent)
               and then not Entry_Accepted (Ent)
@@ -1799,6 +1866,8 @@ package body Sem_Ch9 is
       --  Ada 2005 (AI-345)
 
       if Present (Interface_List (N)) then
+         Set_Is_Tagged_Type (T);
+
          Iface := First (Interface_List (N));
          while Present (Iface) loop
             Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
@@ -1919,21 +1988,20 @@ package body Sem_Ch9 is
       end if;
 
       Analyze (Trigger);
+
       if Comes_From_Source (Trigger)
-        and then Nkind (Trigger) /= N_Delay_Until_Statement
-        and then Nkind (Trigger) /= N_Delay_Relative_Statement
+        and then Nkind (Trigger) not in N_Delay_Statement
         and then Nkind (Trigger) /= N_Entry_Call_Statement
       then
          if Ada_Version < Ada_05 then
             Error_Msg_N
              ("triggering statement must be delay or entry call", Trigger);
 
-         --  Ada 2005 (AI-345): If a procedure_call_statement is used
-         --  for a procedure_or_entry_call, the procedure_name or pro-
-         --  cedure_prefix of the procedure_call_statement shall denote
-         --  an entry renamed by a procedure, or (a view of) a primitive
-         --  subprogram of a limited interface whose first parameter is
-         --  a controlling parameter.
+         --  Ada 2005 (AI-345): If a procedure_call_statement is used for a
+         --  procedure_or_entry_call, the procedure_name or pro- cedure_prefix
+         --  of the procedure_call_statement shall denote an entry renamed by a
+         --  procedure, or (a view of) a primitive subprogram of a limited
+         --  interface whose first parameter is a controlling parameter.
 
          elsif Nkind (Trigger) = N_Procedure_Call_Statement
            and then not Is_Renamed_Entry (Entity (Name (Trigger)))
@@ -2089,7 +2157,6 @@ package body Sem_Ch9 is
 
          begin
             Ent := First (Ifaces);
-
             while Present (Ent) loop
                if Etype (Ent) = Iface then
                   return True;
@@ -2119,14 +2186,13 @@ package body Sem_Ch9 is
 
          Entry_Param := First (Entry_Params);
          Proc_Param  := Next (Proc_Param);
-         while Present (Entry_Param)
-           and then Present (Proc_Param)
-         loop
+         while Present (Entry_Param) and then Present (Proc_Param) loop
+
             --  The two parameters must be mode conformant and have the exact
             --  same types.
 
-            if In_Present (Entry_Param) /= In_Present (Proc_Param)
-              or else Out_Present (Entry_Param) /= Out_Present (Proc_Param)
+            if Ekind (Defining_Identifier (Entry_Param)) /=
+               Ekind (Defining_Identifier (Proc_Param))
               or else Etype (Parameter_Type (Entry_Param)) /=
                       Etype (Parameter_Type (Proc_Param))
             then
@@ -2177,7 +2243,6 @@ package body Sem_Ch9 is
                               Null_Present (Parent (Hom)))
                   then
                      Aliased_Hom := Hom;
-
                      while Present (Alias (Aliased_Hom)) loop
                         Aliased_Hom := Alias (Aliased_Hom);
                      end loop;
@@ -2274,7 +2339,6 @@ package body Sem_Ch9 is
 
       else
          Decl := First (Vis_Decls);
-
          while Present (Decl) loop
             if Nkind (Decl) = N_Entry_Declaration
               and then Must_Override (Decl)
@@ -2322,7 +2386,6 @@ package body Sem_Ch9 is
 
    begin
       E := First_Entity (Spec);
-
       while Present (E) loop
          Prev := Current_Entity (E);
          Set_Current_Entity (E);

gcc/ada/snames.adb

@@ -93,6 +93,7 @@ package body Snames is
      "_disp_conditional_select#" &
      "_disp_get_prim_op_kind#" &
      "_disp_timed_select#" &
+     "_disp_get_task_id#" &
      "initialize#" &
      "adjust#" &
      "finalize#" &
@@ -458,6 +459,7 @@ package body Snames is
      "machine_mantissa#" &
      "machine_overflows#" &
      "machine_radix#" &
+     "machine_rounding#" &
      "machine_rounds#" &
      "machine_size#" &
      "mantissa#" &
@@ -639,6 +641,7 @@ package body Snames is
      "unchecked_conversion#" &
      "unchecked_deallocation#" &
      "to_pointer#" &
+     "free#" &
      "abstract#" &
      "aliased#" &
      "protected#" &
@@ -674,6 +677,7 @@ package body Snames is
      "include_option#" &
      "language_processing#" &
      "languages#" &
+     "library_ali_dir#" &
      "library_dir#" &
      "library_auto_init#" &
      "library_gcc#" &

gcc/ada/snames.ads

@@ -181,127 +181,132 @@ package Snames is
    Name_uDisp_Get_Prim_Op_Kind         : constant Name_Id := N + 034;
    Name_uDisp_Timed_Select             : constant Name_Id := N + 035;
 
+   --  Names of routines used in the expansion of Abort, attributes 'Callable
+   --  and 'Terminated for task interface class-wide types.
+
+   Name_uDisp_Get_Task_Id              : constant Name_Id := N + 036;
+
    --  Names of routines in Ada.Finalization, needed by expander
 
-   Name_Initialize                     : constant Name_Id := N + 036;
-   Name_Adjust                         : constant Name_Id := N + 037;
-   Name_Finalize                       : constant Name_Id := N + 038;
+   Name_Initialize                     : constant Name_Id := N + 037;
+   Name_Adjust                         : constant Name_Id := N + 038;
+   Name_Finalize                       : constant Name_Id := N + 039;
 
    --  Names of fields declared in System.Finalization_Implementation,
    --  needed by the expander when generating code for finalization.
 
-   Name_Next                           : constant Name_Id := N + 039;
-   Name_Prev                           : constant Name_Id := N + 040;
+   Name_Next                           : constant Name_Id := N + 040;
+   Name_Prev                           : constant Name_Id := N + 041;
 
    --  Names of TSS routines for implementation of DSA over PolyORB
 
-   Name_uTypeCode                      : constant Name_Id := N + 041;
-   Name_uFrom_Any                      : constant Name_Id := N + 042;
-   Name_uTo_Any                        : constant Name_Id := N + 043;
+   Name_uTypeCode                      : constant Name_Id := N + 042;
+   Name_uFrom_Any                      : constant Name_Id := N + 043;
+   Name_uTo_Any                        : constant Name_Id := N + 044;
 
    --  Names of allocation routines, also needed by expander
 
-   Name_Allocate                       : constant Name_Id := N + 044;
-   Name_Deallocate                     : constant Name_Id := N + 045;
-   Name_Dereference                    : constant Name_Id := N + 046;
+   Name_Allocate                       : constant Name_Id := N + 045;
+   Name_Deallocate                     : constant Name_Id := N + 046;
+   Name_Dereference                    : constant Name_Id := N + 047;
 
    --  Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge)
 
-   First_Text_IO_Package               : constant Name_Id := N + 047;
-   Name_Decimal_IO                     : constant Name_Id := N + 047;
-   Name_Enumeration_IO                 : constant Name_Id := N + 048;
-   Name_Fixed_IO                       : constant Name_Id := N + 049;
-   Name_Float_IO                       : constant Name_Id := N + 050;
-   Name_Integer_IO                     : constant Name_Id := N + 051;
-   Name_Modular_IO                     : constant Name_Id := N + 052;
-   Last_Text_IO_Package                : constant Name_Id := N + 052;
+   First_Text_IO_Package               : constant Name_Id := N + 048;
+   Name_Decimal_IO                     : constant Name_Id := N + 048;
+   Name_Enumeration_IO                 : constant Name_Id := N + 049;
+   Name_Fixed_IO                       : constant Name_Id := N + 050;
+   Name_Float_IO                       : constant Name_Id := N + 051;
+   Name_Integer_IO                     : constant Name_Id := N + 052;
+   Name_Modular_IO                     : constant Name_Id := N + 053;
+   Last_Text_IO_Package                : constant Name_Id := N + 053;
 
    subtype Text_IO_Package_Name is Name_Id
      range First_Text_IO_Package .. Last_Text_IO_Package;
 
    --  Some miscellaneous names used for error detection/recovery
 
-   Name_Const                          : constant Name_Id := N + 053;
-   Name_Error                          : constant Name_Id := N + 054;
-   Name_Go                             : constant Name_Id := N + 055;
-   Name_Put                            : constant Name_Id := N + 056;
-   Name_Put_Line                       : constant Name_Id := N + 057;
-   Name_To                             : constant Name_Id := N + 058;
+   Name_Const                          : constant Name_Id := N + 054;
+   Name_Error                          : constant Name_Id := N + 055;
+   Name_Go                             : constant Name_Id := N + 056;
+   Name_Put                            : constant Name_Id := N + 057;
+   Name_Put_Line                       : constant Name_Id := N + 058;
+   Name_To                             : constant Name_Id := N + 059;
 
    --  Names for packages that are treated specially by the compiler
 
-   Name_Finalization                   : constant Name_Id := N + 059;
-   Name_Finalization_Root              : constant Name_Id := N + 060;
-   Name_Interfaces                     : constant Name_Id := N + 061;
-   Name_Standard                       : constant Name_Id := N + 062;
-   Name_System                         : constant Name_Id := N + 063;
-   Name_Text_IO                        : constant Name_Id := N + 064;
-   Name_Wide_Text_IO                   : constant Name_Id := N + 065;
-   Name_Wide_Wide_Text_IO              : constant Name_Id := N + 066;
+   Name_Finalization                   : constant Name_Id := N + 060;
+   Name_Finalization_Root              : constant Name_Id := N + 061;
+   Name_Interfaces                     : constant Name_Id := N + 062;
+   Name_Standard                       : constant Name_Id := N + 063;
+   Name_System                         : constant Name_Id := N + 064;
+   Name_Text_IO                        : constant Name_Id := N + 065;
+   Name_Wide_Text_IO                   : constant Name_Id := N + 066;
+   Name_Wide_Wide_Text_IO              : constant Name_Id := N + 067;
 
    --  Names of implementations of the distributed systems annex
 
-   First_PCS_Name                      : constant Name_Id := N + 067;
-   Name_No_DSA                         : constant Name_Id := N + 067;
-   Name_GARLIC_DSA                     : constant Name_Id := N + 068;
-   Name_PolyORB_DSA                    : constant Name_Id := N + 069;
-   Last_PCS_Name                       : constant Name_Id := N + 069;
+   First_PCS_Name                      : constant Name_Id := N + 068;
+   Name_No_DSA                         : constant Name_Id := N + 068;
+   Name_GARLIC_DSA                     : constant Name_Id := N + 069;
+   Name_PolyORB_DSA                    : constant Name_Id := N + 070;
+   Last_PCS_Name                       : constant Name_Id := N + 070;
 
    subtype PCS_Names is Name_Id
      range First_PCS_Name .. Last_PCS_Name;
 
    --  Names of identifiers used in expanding distribution stubs
 
-   Name_Addr                           : constant Name_Id := N + 070;
-   Name_Async                          : constant Name_Id := N + 071;
-   Name_Get_Active_Partition_ID        : constant Name_Id := N + 072;
-   Name_Get_RCI_Package_Receiver       : constant Name_Id := N + 073;
-   Name_Get_RCI_Package_Ref            : constant Name_Id := N + 074;
-   Name_Origin                         : constant Name_Id := N + 075;
-   Name_Params                         : constant Name_Id := N + 076;
-   Name_Partition                      : constant Name_Id := N + 077;
-   Name_Partition_Interface            : constant Name_Id := N + 078;
-   Name_Ras                            : constant Name_Id := N + 079;
-   Name_Call                           : constant Name_Id := N + 080;
-   Name_RCI_Name                       : constant Name_Id := N + 081;
-   Name_Receiver                       : constant Name_Id := N + 082;
-   Name_Result                         : constant Name_Id := N + 083;
-   Name_Rpc                            : constant Name_Id := N + 084;
-   Name_Subp_Id                        : constant Name_Id := N + 085;
-   Name_Operation                      : constant Name_Id := N + 086;
-   Name_Argument                       : constant Name_Id := N + 087;
-   Name_Arg_Modes                      : constant Name_Id := N + 088;
-   Name_Handler                        : constant Name_Id := N + 089;
-   Name_Target                         : constant Name_Id := N + 090;
-   Name_Req                            : constant Name_Id := N + 091;
-   Name_Obj_TypeCode                   : constant Name_Id := N + 092;
-   Name_Stub                           : constant Name_Id := N + 093;
+   Name_Addr                           : constant Name_Id := N + 071;
+   Name_Async                          : constant Name_Id := N + 072;
+   Name_Get_Active_Partition_ID        : constant Name_Id := N + 073;
+   Name_Get_RCI_Package_Receiver       : constant Name_Id := N + 074;
+   Name_Get_RCI_Package_Ref            : constant Name_Id := N + 075;
+   Name_Origin                         : constant Name_Id := N + 076;
+   Name_Params                         : constant Name_Id := N + 077;
+   Name_Partition                      : constant Name_Id := N + 078;
+   Name_Partition_Interface            : constant Name_Id := N + 079;
+   Name_Ras                            : constant Name_Id := N + 080;
+   Name_Call                           : constant Name_Id := N + 081;
+   Name_RCI_Name                       : constant Name_Id := N + 082;
+   Name_Receiver                       : constant Name_Id := N + 083;
+   Name_Result                         : constant Name_Id := N + 084;
+   Name_Rpc                            : constant Name_Id := N + 085;
+   Name_Subp_Id                        : constant Name_Id := N + 086;
+   Name_Operation                      : constant Name_Id := N + 087;
+   Name_Argument                       : constant Name_Id := N + 088;
+   Name_Arg_Modes                      : constant Name_Id := N + 089;
+   Name_Handler                        : constant Name_Id := N + 090;
+   Name_Target                         : constant Name_Id := N + 091;
+   Name_Req                            : constant Name_Id := N + 092;
+   Name_Obj_TypeCode                   : constant Name_Id := N + 093;
+   Name_Stub                           : constant Name_Id := N + 094;
 
    --  Operator Symbol entries. The actual names have an upper case O at
    --  the start in place of the Op_ prefix (e.g. the actual name that
    --  corresponds to Name_Op_Abs is "Oabs".
 
-   First_Operator_Name                 : constant Name_Id := N + 094;
-   Name_Op_Abs                         : constant Name_Id := N + 094; -- "abs"
-   Name_Op_And                         : constant Name_Id := N + 095; -- "and"
-   Name_Op_Mod                         : constant Name_Id := N + 096; -- "mod"
-   Name_Op_Not                         : constant Name_Id := N + 097; -- "not"
-   Name_Op_Or                          : constant Name_Id := N + 098; -- "or"
-   Name_Op_Rem                         : constant Name_Id := N + 099; -- "rem"
-   Name_Op_Xor                         : constant Name_Id := N + 100; -- "xor"
-   Name_Op_Eq                          : constant Name_Id := N + 101; -- "="
-   Name_Op_Ne                          : constant Name_Id := N + 102; -- "/="
-   Name_Op_Lt                          : constant Name_Id := N + 103; -- "<"
-   Name_Op_Le                          : constant Name_Id := N + 104; -- "<="
-   Name_Op_Gt                          : constant Name_Id := N + 105; -- ">"
-   Name_Op_Ge                          : constant Name_Id := N + 106; -- ">="
-   Name_Op_Add                         : constant Name_Id := N + 107; -- "+"
-   Name_Op_Subtract                    : constant Name_Id := N + 108; -- "-"
-   Name_Op_Concat                      : constant Name_Id := N + 109; -- "&"
-   Name_Op_Multiply                    : constant Name_Id := N + 110; -- "*"
-   Name_Op_Divide                      : constant Name_Id := N + 111; -- "/"
-   Name_Op_Expon                       : constant Name_Id := N + 112; -- "**"
-   Last_Operator_Name                  : constant Name_Id := N + 112;
+   First_Operator_Name                 : constant Name_Id := N + 095;
+   Name_Op_Abs                         : constant Name_Id := N + 095; -- "abs"
+   Name_Op_And                         : constant Name_Id := N + 096; -- "and"
+   Name_Op_Mod                         : constant Name_Id := N + 097; -- "mod"
+   Name_Op_Not                         : constant Name_Id := N + 098; -- "not"
+   Name_Op_Or                          : constant Name_Id := N + 099; -- "or"
+   Name_Op_Rem                         : constant Name_Id := N + 100; -- "rem"
+   Name_Op_Xor                         : constant Name_Id := N + 101; -- "xor"
+   Name_Op_Eq                          : constant Name_Id := N + 102; -- "="
+   Name_Op_Ne                          : constant Name_Id := N + 103; -- "/="
+   Name_Op_Lt                          : constant Name_Id := N + 104; -- "<"
+   Name_Op_Le                          : constant Name_Id := N + 105; -- "<="
+   Name_Op_Gt                          : constant Name_Id := N + 106; -- ">"
+   Name_Op_Ge                          : constant Name_Id := N + 107; -- ">="
+   Name_Op_Add                         : constant Name_Id := N + 108; -- "+"
+   Name_Op_Subtract                    : constant Name_Id := N + 109; -- "-"
+   Name_Op_Concat                      : constant Name_Id := N + 110; -- "&"
+   Name_Op_Multiply                    : constant Name_Id := N + 111; -- "*"
+   Name_Op_Divide                      : constant Name_Id := N + 112; -- "/"
+   Name_Op_Expon                       : constant Name_Id := N + 113; -- "**"
+   Last_Operator_Name                  : constant Name_Id := N + 113;
 
    --  Names for all pragmas recognized by GNAT. The entries with the comment
    --  "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95.
@@ -324,65 +329,65 @@ package Snames is
    --  only in GNAT for the AAMP. They are ignored in other versions with
    --  appropriate warnings.
 
-   First_Pragma_Name                   : constant Name_Id := N + 113;
+   First_Pragma_Name                   : constant Name_Id := N + 114;
 
    --  Configuration pragmas are grouped at start
 
-   Name_Ada_83                         : constant Name_Id := N + 113; -- GNAT
-   Name_Ada_95                         : constant Name_Id := N + 114; -- GNAT
-   Name_Ada_05                         : constant Name_Id := N + 115; -- GNAT
-   Name_Assertion_Policy               : constant Name_Id := N + 116; -- Ada 05
-   Name_C_Pass_By_Copy                 : constant Name_Id := N + 117; -- GNAT
-   Name_Compile_Time_Warning           : constant Name_Id := N + 118; -- GNAT
-   Name_Component_Alignment            : constant Name_Id := N + 119; -- GNAT
-   Name_Convention_Identifier          : constant Name_Id := N + 120; -- GNAT
-   Name_Debug_Policy                   : constant Name_Id := N + 121; -- GNAT
-   Name_Detect_Blocking                : constant Name_Id := N + 122; -- Ada 05
-   Name_Discard_Names                  : constant Name_Id := N + 123;
-   Name_Elaboration_Checks             : constant Name_Id := N + 124; -- GNAT
-   Name_Eliminate                      : constant Name_Id := N + 125; -- GNAT
-   Name_Explicit_Overriding            : constant Name_Id := N + 126; -- Ada 05
-   Name_Extend_System                  : constant Name_Id := N + 127; -- GNAT
-   Name_Extensions_Allowed             : constant Name_Id := N + 128; -- GNAT
-   Name_External_Name_Casing           : constant Name_Id := N + 129; -- GNAT
-   Name_Float_Representation           : constant Name_Id := N + 130; -- GNAT
-   Name_Initialize_Scalars             : constant Name_Id := N + 131; -- GNAT
-   Name_Interrupt_State                : constant Name_Id := N + 132; -- GNAT
-   Name_License                        : constant Name_Id := N + 133; -- GNAT
-   Name_Locking_Policy                 : constant Name_Id := N + 134;
-   Name_Long_Float                     : constant Name_Id := N + 135; -- VMS
-   Name_No_Run_Time                    : constant Name_Id := N + 136; -- GNAT
-   Name_No_Strict_Aliasing             : constant Name_Id := N + 137; -- GNAT
-   Name_Normalize_Scalars              : constant Name_Id := N + 138;
-   Name_Polling                        : constant Name_Id := N + 139; -- GNAT
-   Name_Persistent_BSS                 : constant Name_Id := N + 140; -- GNAT
-   Name_Profile                        : constant Name_Id := N + 141; -- Ada 05
-   Name_Profile_Warnings               : constant Name_Id := N + 142; -- GNAT
-   Name_Propagate_Exceptions           : constant Name_Id := N + 143; -- GNAT
-   Name_Queuing_Policy                 : constant Name_Id := N + 144;
-   Name_Ravenscar                      : constant Name_Id := N + 145; -- Ada 05
-   Name_Restricted_Run_Time            : constant Name_Id := N + 146; -- GNAT
-   Name_Restrictions                   : constant Name_Id := N + 147;
-   Name_Restriction_Warnings           : constant Name_Id := N + 148; -- GNAT
-   Name_Reviewable                     : constant Name_Id := N + 149;
-   Name_Source_File_Name               : constant Name_Id := N + 150; -- GNAT
-   Name_Source_File_Name_Project       : constant Name_Id := N + 151; -- GNAT
-   Name_Style_Checks                   : constant Name_Id := N + 152; -- GNAT
-   Name_Suppress                       : constant Name_Id := N + 153;
-   Name_Suppress_Exception_Locations   : constant Name_Id := N + 154; -- GNAT
-   Name_Task_Dispatching_Policy        : constant Name_Id := N + 155;
-   Name_Universal_Data                 : constant Name_Id := N + 156; -- AAMP
-   Name_Unsuppress                     : constant Name_Id := N + 157; -- GNAT
-   Name_Use_VADS_Size                  : constant Name_Id := N + 158; -- GNAT
-   Name_Validity_Checks                : constant Name_Id := N + 159; -- GNAT
-   Name_Warnings                       : constant Name_Id := N + 160; -- GNAT
-   Last_Configuration_Pragma_Name      : constant Name_Id := N + 160;
+   Name_Ada_83                         : constant Name_Id := N + 114; -- GNAT
+   Name_Ada_95                         : constant Name_Id := N + 115; -- GNAT
+   Name_Ada_05                         : constant Name_Id := N + 116; -- GNAT
+   Name_Assertion_Policy               : constant Name_Id := N + 117; -- Ada 05
+   Name_C_Pass_By_Copy                 : constant Name_Id := N + 118; -- GNAT
+   Name_Compile_Time_Warning           : constant Name_Id := N + 119; -- GNAT
+   Name_Component_Alignment            : constant Name_Id := N + 120; -- GNAT
+   Name_Convention_Identifier          : constant Name_Id := N + 121; -- GNAT
+   Name_Debug_Policy                   : constant Name_Id := N + 122; -- GNAT
+   Name_Detect_Blocking                : constant Name_Id := N + 123; -- Ada 05
+   Name_Discard_Names                  : constant Name_Id := N + 124;
+   Name_Elaboration_Checks             : constant Name_Id := N + 125; -- GNAT
+   Name_Eliminate                      : constant Name_Id := N + 126; -- GNAT
+   Name_Explicit_Overriding            : constant Name_Id := N + 127; -- Ada 05
+   Name_Extend_System                  : constant Name_Id := N + 128; -- GNAT
+   Name_Extensions_Allowed             : constant Name_Id := N + 129; -- GNAT
+   Name_External_Name_Casing           : constant Name_Id := N + 130; -- GNAT
+   Name_Float_Representation           : constant Name_Id := N + 131; -- GNAT
+   Name_Initialize_Scalars             : constant Name_Id := N + 132; -- GNAT
+   Name_Interrupt_State                : constant Name_Id := N + 133; -- GNAT
+   Name_License                        : constant Name_Id := N + 134; -- GNAT
+   Name_Locking_Policy                 : constant Name_Id := N + 135;
+   Name_Long_Float                     : constant Name_Id := N + 136; -- VMS
+   Name_No_Run_Time                    : constant Name_Id := N + 137; -- GNAT
+   Name_No_Strict_Aliasing             : constant Name_Id := N + 138; -- GNAT
+   Name_Normalize_Scalars              : constant Name_Id := N + 139;
+   Name_Polling                        : constant Name_Id := N + 140; -- GNAT
+   Name_Persistent_BSS                 : constant Name_Id := N + 141; -- GNAT
+   Name_Profile                        : constant Name_Id := N + 142; -- Ada 05
+   Name_Profile_Warnings               : constant Name_Id := N + 143; -- GNAT
+   Name_Propagate_Exceptions           : constant Name_Id := N + 144; -- GNAT
+   Name_Queuing_Policy                 : constant Name_Id := N + 145;
+   Name_Ravenscar                      : constant Name_Id := N + 146; -- Ada 05
+   Name_Restricted_Run_Time            : constant Name_Id := N + 147; -- GNAT
+   Name_Restrictions                   : constant Name_Id := N + 148;
+   Name_Restriction_Warnings           : constant Name_Id := N + 149; -- GNAT
+   Name_Reviewable                     : constant Name_Id := N + 150;
+   Name_Source_File_Name               : constant Name_Id := N + 151; -- GNAT
+   Name_Source_File_Name_Project       : constant Name_Id := N + 152; -- GNAT
+   Name_Style_Checks                   : constant Name_Id := N + 153; -- GNAT
+   Name_Suppress                       : constant Name_Id := N + 154;
+   Name_Suppress_Exception_Locations   : constant Name_Id := N + 155; -- GNAT
+   Name_Task_Dispatching_Policy        : constant Name_Id := N + 156;
+   Name_Universal_Data                 : constant Name_Id := N + 157; -- AAMP
+   Name_Unsuppress                     : constant Name_Id := N + 158; -- GNAT
+   Name_Use_VADS_Size                  : constant Name_Id := N + 159; -- GNAT
+   Name_Validity_Checks                : constant Name_Id := N + 160; -- GNAT
+   Name_Warnings                       : constant Name_Id := N + 161; -- GNAT
+   Last_Configuration_Pragma_Name      : constant Name_Id := N + 161;
 
    --  Remaining pragma names
 
-   Name_Abort_Defer                    : constant Name_Id := N + 161; -- GNAT
-   Name_All_Calls_Remote               : constant Name_Id := N + 162;
-   Name_Annotate                       : constant Name_Id := N + 163; -- GNAT
+   Name_Abort_Defer                    : constant Name_Id := N + 162; -- GNAT
+   Name_All_Calls_Remote               : constant Name_Id := N + 163;
+   Name_Annotate                       : constant Name_Id := N + 164; -- GNAT
 
    --  Note: AST_Entry is not in this list because its name matches the
    --  name of the corresponding attribute. However, it is included in the
@@ -390,80 +395,80 @@ package Snames is
    --  and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
    --  AST_Entry is a VMS specific pragma.
 
-   Name_Assert                         : constant Name_Id := N + 164; -- Ada 05
-   Name_Asynchronous                   : constant Name_Id := N + 165;
-   Name_Atomic                         : constant Name_Id := N + 166;
-   Name_Atomic_Components              : constant Name_Id := N + 167;
-   Name_Attach_Handler                 : constant Name_Id := N + 168;
-   Name_Comment                        : constant Name_Id := N + 169; -- GNAT
-   Name_Common_Object                  : constant Name_Id := N + 170; -- GNAT
-   Name_Complex_Representation         : constant Name_Id := N + 171; -- GNAT
-   Name_Controlled                     : constant Name_Id := N + 172;
-   Name_Convention                     : constant Name_Id := N + 173;
-   Name_CPP_Class                      : constant Name_Id := N + 174; -- GNAT
-   Name_CPP_Constructor                : constant Name_Id := N + 175; -- GNAT
-   Name_CPP_Virtual                    : constant Name_Id := N + 176; -- GNAT
-   Name_CPP_Vtable                     : constant Name_Id := N + 177; -- GNAT
-   Name_Debug                          : constant Name_Id := N + 178; -- GNAT
-   Name_Elaborate                      : constant Name_Id := N + 179; -- Ada 83
-   Name_Elaborate_All                  : constant Name_Id := N + 180;
-   Name_Elaborate_Body                 : constant Name_Id := N + 181;
-   Name_Export                         : constant Name_Id := N + 182;
-   Name_Export_Exception               : constant Name_Id := N + 183; -- VMS
-   Name_Export_Function                : constant Name_Id := N + 184; -- GNAT
-   Name_Export_Object                  : constant Name_Id := N + 185; -- GNAT
-   Name_Export_Procedure               : constant Name_Id := N + 186; -- GNAT
-   Name_Export_Value                   : constant Name_Id := N + 187; -- GNAT
-   Name_Export_Valued_Procedure        : constant Name_Id := N + 188; -- GNAT
-   Name_External                       : constant Name_Id := N + 189; -- GNAT
-   Name_Finalize_Storage_Only          : constant Name_Id := N + 190; -- GNAT
-   Name_Ident                          : constant Name_Id := N + 191; -- VMS
-   Name_Import                         : constant Name_Id := N + 192;
-   Name_Import_Exception               : constant Name_Id := N + 193; -- VMS
-   Name_Import_Function                : constant Name_Id := N + 194; -- GNAT
-   Name_Import_Object                  : constant Name_Id := N + 195; -- GNAT
-   Name_Import_Procedure               : constant Name_Id := N + 196; -- GNAT
-   Name_Import_Valued_Procedure        : constant Name_Id := N + 197; -- GNAT
-   Name_Inline                         : constant Name_Id := N + 198;
-   Name_Inline_Always                  : constant Name_Id := N + 199; -- GNAT
-   Name_Inline_Generic                 : constant Name_Id := N + 200; -- GNAT
-   Name_Inspection_Point               : constant Name_Id := N + 201;
-   Name_Interface_Name                 : constant Name_Id := N + 202; -- GNAT
-   Name_Interrupt_Handler              : constant Name_Id := N + 203;
-   Name_Interrupt_Priority             : constant Name_Id := N + 204;
-   Name_Java_Constructor               : constant Name_Id := N + 205; -- GNAT
-   Name_Java_Interface                 : constant Name_Id := N + 206; -- GNAT
-   Name_Keep_Names                     : constant Name_Id := N + 207; -- GNAT
-   Name_Link_With                      : constant Name_Id := N + 208; -- GNAT
-   Name_Linker_Alias                   : constant Name_Id := N + 209; -- GNAT
-   Name_Linker_Constructor             : constant Name_Id := N + 210; -- GNAT
-   Name_Linker_Destructor              : constant Name_Id := N + 211; -- GNAT
-   Name_Linker_Options                 : constant Name_Id := N + 212;
-   Name_Linker_Section                 : constant Name_Id := N + 213; -- GNAT
-   Name_List                           : constant Name_Id := N + 214;
-   Name_Machine_Attribute              : constant Name_Id := N + 215; -- GNAT
-   Name_Main                           : constant Name_Id := N + 216; -- GNAT
-   Name_Main_Storage                   : constant Name_Id := N + 217; -- GNAT
-   Name_Memory_Size                    : constant Name_Id := N + 218; -- Ada 83
-   Name_No_Return                      : constant Name_Id := N + 219; -- GNAT
-   Name_Obsolescent                    : constant Name_Id := N + 220; -- GNAT
-   Name_Optimize                       : constant Name_Id := N + 221;
-   Name_Optional_Overriding            : constant Name_Id := N + 222; -- Ada 05
-   Name_Pack                           : constant Name_Id := N + 223;
-   Name_Page                           : constant Name_Id := N + 224;
-   Name_Passive                        : constant Name_Id := N + 225; -- GNAT
-   Name_Preelaborate                   : constant Name_Id := N + 226;
-   Name_Preelaborate_05                : constant Name_Id := N + 227; -- GNAT
-   Name_Priority                       : constant Name_Id := N + 228;
-   Name_Psect_Object                   : constant Name_Id := N + 229; -- VMS
-   Name_Pure                           : constant Name_Id := N + 230;
-   Name_Pure_05                        : constant Name_Id := N + 231; -- GNAT
-   Name_Pure_Function                  : constant Name_Id := N + 232; -- GNAT
-   Name_Remote_Call_Interface          : constant Name_Id := N + 233;
-   Name_Remote_Types                   : constant Name_Id := N + 234;
-   Name_Share_Generic                  : constant Name_Id := N + 235; -- GNAT
-   Name_Shared                         : constant Name_Id := N + 236; -- Ada 83
-   Name_Shared_Passive                 : constant Name_Id := N + 237;
+   Name_Assert                         : constant Name_Id := N + 165; -- Ada 05
+   Name_Asynchronous                   : constant Name_Id := N + 166;
+   Name_Atomic                         : constant Name_Id := N + 167;
+   Name_Atomic_Components              : constant Name_Id := N + 168;
+   Name_Attach_Handler                 : constant Name_Id := N + 169;
+   Name_Comment                        : constant Name_Id := N + 170; -- GNAT
+   Name_Common_Object                  : constant Name_Id := N + 171; -- GNAT
+   Name_Complex_Representation         : constant Name_Id := N + 172; -- GNAT
+   Name_Controlled                     : constant Name_Id := N + 173;
+   Name_Convention                     : constant Name_Id := N + 174;
+   Name_CPP_Class                      : constant Name_Id := N + 175; -- GNAT
+   Name_CPP_Constructor                : constant Name_Id := N + 176; -- GNAT
+   Name_CPP_Virtual                    : constant Name_Id := N + 177; -- GNAT
+   Name_CPP_Vtable                     : constant Name_Id := N + 178; -- GNAT
+   Name_Debug                          : constant Name_Id := N + 179; -- GNAT
+   Name_Elaborate                      : constant Name_Id := N + 180; -- Ada 83
+   Name_Elaborate_All                  : constant Name_Id := N + 181;
+   Name_Elaborate_Body                 : constant Name_Id := N + 182;
+   Name_Export                         : constant Name_Id := N + 183;
+   Name_Export_Exception               : constant Name_Id := N + 184; -- VMS
+   Name_Export_Function                : constant Name_Id := N + 185; -- GNAT
+   Name_Export_Object                  : constant Name_Id := N + 186; -- GNAT
+   Name_Export_Procedure               : constant Name_Id := N + 187; -- GNAT
+   Name_Export_Value                   : constant Name_Id := N + 188; -- GNAT
+   Name_Export_Valued_Procedure        : constant Name_Id := N + 189; -- GNAT
+   Name_External                       : constant Name_Id := N + 190; -- GNAT
+   Name_Finalize_Storage_Only          : constant Name_Id := N + 191; -- GNAT
+   Name_Ident                          : constant Name_Id := N + 192; -- VMS
+   Name_Import                         : constant Name_Id := N + 193;
+   Name_Import_Exception               : constant Name_Id := N + 194; -- VMS
+   Name_Import_Function                : constant Name_Id := N + 195; -- GNAT
+   Name_Import_Object                  : constant Name_Id := N + 196; -- GNAT
+   Name_Import_Procedure               : constant Name_Id := N + 197; -- GNAT
+   Name_Import_Valued_Procedure        : constant Name_Id := N + 198; -- GNAT
+   Name_Inline                         : constant Name_Id := N + 199;
+   Name_Inline_Always                  : constant Name_Id := N + 200; -- GNAT
+   Name_Inline_Generic                 : constant Name_Id := N + 201; -- GNAT
+   Name_Inspection_Point               : constant Name_Id := N + 202;
+   Name_Interface_Name                 : constant Name_Id := N + 203; -- GNAT
+   Name_Interrupt_Handler              : constant Name_Id := N + 204;
+   Name_Interrupt_Priority             : constant Name_Id := N + 205;
+   Name_Java_Constructor               : constant Name_Id := N + 206; -- GNAT
+   Name_Java_Interface                 : constant Name_Id := N + 207; -- GNAT
+   Name_Keep_Names                     : constant Name_Id := N + 208; -- GNAT
+   Name_Link_With                      : constant Name_Id := N + 209; -- GNAT
+   Name_Linker_Alias                   : constant Name_Id := N + 210; -- GNAT
+   Name_Linker_Constructor             : constant Name_Id := N + 211; -- GNAT
+   Name_Linker_Destructor              : constant Name_Id := N + 212; -- GNAT
+   Name_Linker_Options                 : constant Name_Id := N + 213;
+   Name_Linker_Section                 : constant Name_Id := N + 214; -- GNAT
+   Name_List                           : constant Name_Id := N + 215;
+   Name_Machine_Attribute              : constant Name_Id := N + 216; -- GNAT
+   Name_Main                           : constant Name_Id := N + 217; -- GNAT
+   Name_Main_Storage                   : constant Name_Id := N + 218; -- GNAT
+   Name_Memory_Size                    : constant Name_Id := N + 219; -- Ada 83
+   Name_No_Return                      : constant Name_Id := N + 220; -- GNAT
+   Name_Obsolescent                    : constant Name_Id := N + 221; -- GNAT
+   Name_Optimize                       : constant Name_Id := N + 222;
+   Name_Optional_Overriding            : constant Name_Id := N + 223; -- Ada 05
+   Name_Pack                           : constant Name_Id := N + 224;
+   Name_Page                           : constant Name_Id := N + 225;
+   Name_Passive                        : constant Name_Id := N + 226; -- GNAT
+   Name_Preelaborate                   : constant Name_Id := N + 227;
+   Name_Preelaborate_05                : constant Name_Id := N + 228; -- GNAT
+   Name_Priority                       : constant Name_Id := N + 229;
+   Name_Psect_Object                   : constant Name_Id := N + 230; -- VMS
+   Name_Pure                           : constant Name_Id := N + 231;
+   Name_Pure_05                        : constant Name_Id := N + 232; -- GNAT
+   Name_Pure_Function                  : constant Name_Id := N + 233; -- GNAT
+   Name_Remote_Call_Interface          : constant Name_Id := N + 234;
+   Name_Remote_Types                   : constant Name_Id := N + 235;
+   Name_Share_Generic                  : constant Name_Id := N + 236; -- GNAT
+   Name_Shared                         : constant Name_Id := N + 237; -- Ada 83
+   Name_Shared_Passive                 : constant Name_Id := N + 238;
 
    --  Note: Storage_Size is not in this list because its name matches the
    --  name of the corresponding attribute. However, it is included in the
@@ -473,27 +478,27 @@ package Snames is
    --  Note: Storage_Unit is also omitted from the list because of a clash
    --  with an attribute name, and is treated similarly.
 
-   Name_Source_Reference               : constant Name_Id := N + 238; -- GNAT
-   Name_Stream_Convert                 : constant Name_Id := N + 239; -- GNAT
-   Name_Subtitle                       : constant Name_Id := N + 240; -- GNAT
-   Name_Suppress_All                   : constant Name_Id := N + 241; -- GNAT
-   Name_Suppress_Debug_Info            : constant Name_Id := N + 242; -- GNAT
-   Name_Suppress_Initialization        : constant Name_Id := N + 243; -- GNAT
-   Name_System_Name                    : constant Name_Id := N + 244; -- Ada 83
-   Name_Task_Info                      : constant Name_Id := N + 245; -- GNAT
-   Name_Task_Name                      : constant Name_Id := N + 246; -- GNAT
-   Name_Task_Storage                   : constant Name_Id := N + 247; -- VMS
-   Name_Thread_Body                    : constant Name_Id := N + 248; -- GNAT
-   Name_Time_Slice                     : constant Name_Id := N + 249; -- GNAT
-   Name_Title                          : constant Name_Id := N + 250; -- GNAT
-   Name_Unchecked_Union                : constant Name_Id := N + 251; -- GNAT
-   Name_Unimplemented_Unit             : constant Name_Id := N + 252; -- GNAT
-   Name_Unreferenced                   : constant Name_Id := N + 253; -- GNAT
-   Name_Unreserve_All_Interrupts       : constant Name_Id := N + 254; -- GNAT
-   Name_Volatile                       : constant Name_Id := N + 255;
-   Name_Volatile_Components            : constant Name_Id := N + 256;
-   Name_Weak_External                  : constant Name_Id := N + 257; -- GNAT
-   Last_Pragma_Name                    : constant Name_Id := N + 257;
+   Name_Source_Reference               : constant Name_Id := N + 239; -- GNAT
+   Name_Stream_Convert                 : constant Name_Id := N + 240; -- GNAT
+   Name_Subtitle                       : constant Name_Id := N + 241; -- GNAT
+   Name_Suppress_All                   : constant Name_Id := N + 242; -- GNAT
+   Name_Suppress_Debug_Info            : constant Name_Id := N + 243; -- GNAT
+   Name_Suppress_Initialization        : constant Name_Id := N + 244; -- GNAT
+   Name_System_Name                    : constant Name_Id := N + 245; -- Ada 83
+   Name_Task_Info                      : constant Name_Id := N + 246; -- GNAT
+   Name_Task_Name                      : constant Name_Id := N + 247; -- GNAT
+   Name_Task_Storage                   : constant Name_Id := N + 248; -- VMS
+   Name_Thread_Body                    : constant Name_Id := N + 249; -- GNAT
+   Name_Time_Slice                     : constant Name_Id := N + 250; -- GNAT
+   Name_Title                          : constant Name_Id := N + 251; -- GNAT
+   Name_Unchecked_Union                : constant Name_Id := N + 252; -- GNAT
+   Name_Unimplemented_Unit             : constant Name_Id := N + 253; -- GNAT
+   Name_Unreferenced                   : constant Name_Id := N + 254; -- GNAT
+   Name_Unreserve_All_Interrupts       : constant Name_Id := N + 255; -- GNAT
+   Name_Volatile                       : constant Name_Id := N + 256;
+   Name_Volatile_Components            : constant Name_Id := N + 257;
+   Name_Weak_External                  : constant Name_Id := N + 258; -- GNAT
+   Last_Pragma_Name                    : constant Name_Id := N + 258;
 
    --  Language convention names for pragma Convention/Export/Import/Interface
    --  Note that Name_C is not included in this list, since it was already
@@ -504,114 +509,114 @@ package Snames is
    --  Entry and Protected, this is because these conventions cannot be
    --  specified by a pragma.
 
-   First_Convention_Name               : constant Name_Id := N + 258;
-   Name_Ada                            : constant Name_Id := N + 258;
-   Name_Assembler                      : constant Name_Id := N + 259;
-   Name_COBOL                          : constant Name_Id := N + 260;
-   Name_CPP                            : constant Name_Id := N + 261;
-   Name_Fortran                        : constant Name_Id := N + 262;
-   Name_Intrinsic                      : constant Name_Id := N + 263;
-   Name_Java                           : constant Name_Id := N + 264;
-   Name_Stdcall                        : constant Name_Id := N + 265;
-   Name_Stubbed                        : constant Name_Id := N + 266;
-   Last_Convention_Name                : constant Name_Id := N + 266;
+   First_Convention_Name               : constant Name_Id := N + 259;
+   Name_Ada                            : constant Name_Id := N + 259;
+   Name_Assembler                      : constant Name_Id := N + 260;
+   Name_COBOL                          : constant Name_Id := N + 261;
+   Name_CPP                            : constant Name_Id := N + 262;
+   Name_Fortran                        : constant Name_Id := N + 263;
+   Name_Intrinsic                      : constant Name_Id := N + 264;
+   Name_Java                           : constant Name_Id := N + 265;
+   Name_Stdcall                        : constant Name_Id := N + 266;
+   Name_Stubbed                        : constant Name_Id := N + 267;
+   Last_Convention_Name                : constant Name_Id := N + 267;
 
    --  The following names are preset as synonyms for Assembler
 
-   Name_Asm                            : constant Name_Id := N + 267;
-   Name_Assembly                       : constant Name_Id := N + 268;
+   Name_Asm                            : constant Name_Id := N + 268;
+   Name_Assembly                       : constant Name_Id := N + 269;
 
    --  The following names are preset as synonyms for C
 
-   Name_Default                        : constant Name_Id := N + 269;
+   Name_Default                        : constant Name_Id := N + 270;
    --  Name_Exernal (previously defined as pragma)
 
    --  The following names are present as synonyms for Stdcall
 
-   Name_DLL                            : constant Name_Id := N + 270;
-   Name_Win32                          : constant Name_Id := N + 271;
+   Name_DLL                            : constant Name_Id := N + 271;
+   Name_Win32                          : constant Name_Id := N + 272;
 
    --  Other special names used in processing pragmas
 
-   Name_As_Is                          : constant Name_Id := N + 272;
-   Name_Attribute_Name                 : constant Name_Id := N + 273;
-   Name_Body_File_Name                 : constant Name_Id := N + 274;
-   Name_Boolean_Entry_Barriers         : constant Name_Id := N + 275;
-   Name_Check                          : constant Name_Id := N + 276;
-   Name_Casing                         : constant Name_Id := N + 277;
-   Name_Code                           : constant Name_Id := N + 278;
-   Name_Component                      : constant Name_Id := N + 279;
-   Name_Component_Size_4               : constant Name_Id := N + 280;
-   Name_Copy                           : constant Name_Id := N + 281;
-   Name_D_Float                        : constant Name_Id := N + 282;
-   Name_Descriptor                     : constant Name_Id := N + 283;
-   Name_Dot_Replacement                : constant Name_Id := N + 284;
-   Name_Dynamic                        : constant Name_Id := N + 285;
-   Name_Entity                         : constant Name_Id := N + 286;
-   Name_Entry_Count                    : constant Name_Id := N + 287;
-   Name_External_Name                  : constant Name_Id := N + 288;
-   Name_First_Optional_Parameter       : constant Name_Id := N + 289;
-   Name_Form                           : constant Name_Id := N + 290;
-   Name_G_Float                        : constant Name_Id := N + 291;
-   Name_Gcc                            : constant Name_Id := N + 292;
-   Name_Gnat                           : constant Name_Id := N + 293;
-   Name_GPL                            : constant Name_Id := N + 294;
-   Name_IEEE_Float                     : constant Name_Id := N + 295;
-   Name_Ignore                         : constant Name_Id := N + 296;
-   Name_Info                           : constant Name_Id := N + 297;
-   Name_Internal                       : constant Name_Id := N + 298;
-   Name_Link_Name                      : constant Name_Id := N + 299;
-   Name_Lowercase                      : constant Name_Id := N + 300;
-   Name_Max_Entry_Queue_Depth          : constant Name_Id := N + 301;
-   Name_Max_Entry_Queue_Length         : constant Name_Id := N + 302;
-   Name_Max_Size                       : constant Name_Id := N + 303;
-   Name_Mechanism                      : constant Name_Id := N + 304;
-   Name_Message                        : constant Name_Id := N + 305;
-   Name_Mixedcase                      : constant Name_Id := N + 306;
-   Name_Modified_GPL                   : constant Name_Id := N + 307;
-   Name_Name                           : constant Name_Id := N + 308;
-   Name_NCA                            : constant Name_Id := N + 309;
-   Name_No                             : constant Name_Id := N + 310;
-   Name_No_Dependence                  : constant Name_Id := N + 311;
-   Name_No_Dynamic_Attachment          : constant Name_Id := N + 312;
-   Name_No_Dynamic_Interrupts          : constant Name_Id := N + 313;
-   Name_No_Requeue                     : constant Name_Id := N + 314;
-   Name_No_Requeue_Statements          : constant Name_Id := N + 315;
-   Name_No_Task_Attributes             : constant Name_Id := N + 316;
-   Name_No_Task_Attributes_Package     : constant Name_Id := N + 317;
-   Name_On                             : constant Name_Id := N + 318;
-   Name_Parameter_Types                : constant Name_Id := N + 319;
-   Name_Reference                      : constant Name_Id := N + 320;
-   Name_Restricted                     : constant Name_Id := N + 321;
-   Name_Result_Mechanism               : constant Name_Id := N + 322;
-   Name_Result_Type                    : constant Name_Id := N + 323;
-   Name_Runtime                        : constant Name_Id := N + 324;
-   Name_SB                             : constant Name_Id := N + 325;
-   Name_Secondary_Stack_Size           : constant Name_Id := N + 326;
-   Name_Section                        : constant Name_Id := N + 327;
-   Name_Semaphore                      : constant Name_Id := N + 328;
-   Name_Simple_Barriers                : constant Name_Id := N + 329;
-   Name_Spec_File_Name                 : constant Name_Id := N + 330;
-   Name_State                          : constant Name_Id := N + 331;
-   Name_Static                         : constant Name_Id := N + 332;
-   Name_Stack_Size                     : constant Name_Id := N + 333;
-   Name_Subunit_File_Name              : constant Name_Id := N + 334;
-   Name_Task_Stack_Size_Default        : constant Name_Id := N + 335;
-   Name_Task_Type                      : constant Name_Id := N + 336;
-   Name_Time_Slicing_Enabled           : constant Name_Id := N + 337;
-   Name_Top_Guard                      : constant Name_Id := N + 338;
-   Name_UBA                            : constant Name_Id := N + 339;
-   Name_UBS                            : constant Name_Id := N + 340;
-   Name_UBSB                           : constant Name_Id := N + 341;
-   Name_Unit_Name                      : constant Name_Id := N + 342;
-   Name_Unknown                        : constant Name_Id := N + 343;
-   Name_Unrestricted                   : constant Name_Id := N + 344;
-   Name_Uppercase                      : constant Name_Id := N + 345;
-   Name_User                           : constant Name_Id := N + 346;
-   Name_VAX_Float                      : constant Name_Id := N + 347;
-   Name_VMS                            : constant Name_Id := N + 348;
-   Name_Vtable_Ptr                     : constant Name_Id := N + 349;
-   Name_Working_Storage                : constant Name_Id := N + 350;
+   Name_As_Is                          : constant Name_Id := N + 273;
+   Name_Attribute_Name                 : constant Name_Id := N + 274;
+   Name_Body_File_Name                 : constant Name_Id := N + 275;
+   Name_Boolean_Entry_Barriers         : constant Name_Id := N + 276;
+   Name_Check                          : constant Name_Id := N + 277;
+   Name_Casing                         : constant Name_Id := N + 278;
+   Name_Code                           : constant Name_Id := N + 279;
+   Name_Component                      : constant Name_Id := N + 280;
+   Name_Component_Size_4               : constant Name_Id := N + 281;
+   Name_Copy                           : constant Name_Id := N + 282;
+   Name_D_Float                        : constant Name_Id := N + 283;
+   Name_Descriptor                     : constant Name_Id := N + 284;
+   Name_Dot_Replacement                : constant Name_Id := N + 285;
+   Name_Dynamic                        : constant Name_Id := N + 286;
+   Name_Entity                         : constant Name_Id := N + 287;
+   Name_Entry_Count                    : constant Name_Id := N + 288;
+   Name_External_Name                  : constant Name_Id := N + 289;
+   Name_First_Optional_Parameter       : constant Name_Id := N + 290;
+   Name_Form                           : constant Name_Id := N + 291;
+   Name_G_Float                        : constant Name_Id := N + 292;
+   Name_Gcc                            : constant Name_Id := N + 293;
+   Name_Gnat                           : constant Name_Id := N + 294;
+   Name_GPL                            : constant Name_Id := N + 295;
+   Name_IEEE_Float                     : constant Name_Id := N + 296;
+   Name_Ignore                         : constant Name_Id := N + 297;
+   Name_Info                           : constant Name_Id := N + 298;
+   Name_Internal                       : constant Name_Id := N + 299;
+   Name_Link_Name                      : constant Name_Id := N + 300;
+   Name_Lowercase                      : constant Name_Id := N + 301;
+   Name_Max_Entry_Queue_Depth          : constant Name_Id := N + 302;
+   Name_Max_Entry_Queue_Length         : constant Name_Id := N + 303;
+   Name_Max_Size                       : constant Name_Id := N + 304;
+   Name_Mechanism                      : constant Name_Id := N + 305;
+   Name_Message                        : constant Name_Id := N + 306;
+   Name_Mixedcase                      : constant Name_Id := N + 307;
+   Name_Modified_GPL                   : constant Name_Id := N + 308;
+   Name_Name                           : constant Name_Id := N + 309;
+   Name_NCA                            : constant Name_Id := N + 310;
+   Name_No                             : constant Name_Id := N + 311;
+   Name_No_Dependence                  : constant Name_Id := N + 312;
+   Name_No_Dynamic_Attachment          : constant Name_Id := N + 313;
+   Name_No_Dynamic_Interrupts          : constant Name_Id := N + 314;
+   Name_No_Requeue                     : constant Name_Id := N + 315;
+   Name_No_Requeue_Statements          : constant Name_Id := N + 316;
+   Name_No_Task_Attributes             : constant Name_Id := N + 317;
+   Name_No_Task_Attributes_Package     : constant Name_Id := N + 318;
+   Name_On                             : constant Name_Id := N + 319;
+   Name_Parameter_Types                : constant Name_Id := N + 320;
+   Name_Reference                      : constant Name_Id := N + 321;
+   Name_Restricted                     : constant Name_Id := N + 322;
+   Name_Result_Mechanism               : constant Name_Id := N + 323;
+   Name_Result_Type                    : constant Name_Id := N + 324;
+   Name_Runtime                        : constant Name_Id := N + 325;
+   Name_SB                             : constant Name_Id := N + 326;
+   Name_Secondary_Stack_Size           : constant Name_Id := N + 327;
+   Name_Section                        : constant Name_Id := N + 328;
+   Name_Semaphore                      : constant Name_Id := N + 329;
+   Name_Simple_Barriers                : constant Name_Id := N + 330;
+   Name_Spec_File_Name                 : constant Name_Id := N + 331;
+   Name_State                          : constant Name_Id := N + 332;
+   Name_Static                         : constant Name_Id := N + 333;
+   Name_Stack_Size                     : constant Name_Id := N + 334;
+   Name_Subunit_File_Name              : constant Name_Id := N + 335;
+   Name_Task_Stack_Size_Default        : constant Name_Id := N + 336;
+   Name_Task_Type                      : constant Name_Id := N + 337;
+   Name_Time_Slicing_Enabled           : constant Name_Id := N + 338;
+   Name_Top_Guard                      : constant Name_Id := N + 339;
+   Name_UBA                            : constant Name_Id := N + 340;
+   Name_UBS                            : constant Name_Id := N + 341;
+   Name_UBSB                           : constant Name_Id := N + 342;
+   Name_Unit_Name                      : constant Name_Id := N + 343;
+   Name_Unknown                        : constant Name_Id := N + 344;
+   Name_Unrestricted                   : constant Name_Id := N + 345;
+   Name_Uppercase                      : constant Name_Id := N + 346;
+   Name_User                           : constant Name_Id := N + 347;
+   Name_VAX_Float                      : constant Name_Id := N + 348;
+   Name_VMS                            : constant Name_Id := N + 349;
+   Name_Vtable_Ptr                     : constant Name_Id := N + 350;
+   Name_Working_Storage                : constant Name_Id := N + 351;
 
    --  Names of recognized attributes. The entries with the comment "Ada 83"
    --  are attributes that are defined in Ada 83, but not in Ada 95. These
@@ -625,165 +630,166 @@ package Snames is
    --  The entries marked VMS are recognized only in OpenVMS implementations
    --  of GNAT, and are treated as illegal in all other contexts.
 
-   First_Attribute_Name                : constant Name_Id := N + 351;
-   Name_Abort_Signal                   : constant Name_Id := N + 351; -- GNAT
-   Name_Access                         : constant Name_Id := N + 352;
-   Name_Address                        : constant Name_Id := N + 353;
-   Name_Address_Size                   : constant Name_Id := N + 354; -- GNAT
-   Name_Aft                            : constant Name_Id := N + 355;
-   Name_Alignment                      : constant Name_Id := N + 356;
-   Name_Asm_Input                      : constant Name_Id := N + 357; -- GNAT
-   Name_Asm_Output                     : constant Name_Id := N + 358; -- GNAT
-   Name_AST_Entry                      : constant Name_Id := N + 359; -- VMS
-   Name_Bit                            : constant Name_Id := N + 360; -- GNAT
-   Name_Bit_Order                      : constant Name_Id := N + 361;
-   Name_Bit_Position                   : constant Name_Id := N + 362; -- GNAT
-   Name_Body_Version                   : constant Name_Id := N + 363;
-   Name_Callable                       : constant Name_Id := N + 364;
-   Name_Caller                         : constant Name_Id := N + 365;
-   Name_Code_Address                   : constant Name_Id := N + 366; -- GNAT
-   Name_Component_Size                 : constant Name_Id := N + 367;
-   Name_Compose                        : constant Name_Id := N + 368;
-   Name_Constrained                    : constant Name_Id := N + 369;
-   Name_Count                          : constant Name_Id := N + 370;
-   Name_Default_Bit_Order              : constant Name_Id := N + 371; -- GNAT
-   Name_Definite                       : constant Name_Id := N + 372;
-   Name_Delta                          : constant Name_Id := N + 373;
-   Name_Denorm                         : constant Name_Id := N + 374;
-   Name_Digits                         : constant Name_Id := N + 375;
-   Name_Elaborated                     : constant Name_Id := N + 376; -- GNAT
-   Name_Emax                           : constant Name_Id := N + 377; -- Ada 83
-   Name_Enum_Rep                       : constant Name_Id := N + 378; -- GNAT
-   Name_Epsilon                        : constant Name_Id := N + 379; -- Ada 83
-   Name_Exponent                       : constant Name_Id := N + 380;
-   Name_External_Tag                   : constant Name_Id := N + 381;
-   Name_First                          : constant Name_Id := N + 382;
-   Name_First_Bit                      : constant Name_Id := N + 383;
-   Name_Fixed_Value                    : constant Name_Id := N + 384; -- GNAT
-   Name_Fore                           : constant Name_Id := N + 385;
-   Name_Has_Access_Values              : constant Name_Id := N + 386; -- GNAT
-   Name_Has_Discriminants              : constant Name_Id := N + 387; -- GNAT
-   Name_Identity                       : constant Name_Id := N + 388;
-   Name_Img                            : constant Name_Id := N + 389; -- GNAT
-   Name_Integer_Value                  : constant Name_Id := N + 390; -- GNAT
-   Name_Large                          : constant Name_Id := N + 391; -- Ada 83
-   Name_Last                           : constant Name_Id := N + 392;
-   Name_Last_Bit                       : constant Name_Id := N + 393;
-   Name_Leading_Part                   : constant Name_Id := N + 394;
-   Name_Length                         : constant Name_Id := N + 395;
-   Name_Machine_Emax                   : constant Name_Id := N + 396;
-   Name_Machine_Emin                   : constant Name_Id := N + 397;
-   Name_Machine_Mantissa               : constant Name_Id := N + 398;
-   Name_Machine_Overflows              : constant Name_Id := N + 399;
-   Name_Machine_Radix                  : constant Name_Id := N + 400;
-   Name_Machine_Rounds                 : constant Name_Id := N + 401;
-   Name_Machine_Size                   : constant Name_Id := N + 402; -- GNAT
-   Name_Mantissa                       : constant Name_Id := N + 403; -- Ada 83
-   Name_Max_Size_In_Storage_Elements   : constant Name_Id := N + 404;
-   Name_Maximum_Alignment              : constant Name_Id := N + 405; -- GNAT
-   Name_Mechanism_Code                 : constant Name_Id := N + 406; -- GNAT
-   Name_Mod                            : constant Name_Id := N + 407;
-   Name_Model_Emin                     : constant Name_Id := N + 408;
-   Name_Model_Epsilon                  : constant Name_Id := N + 409;
-   Name_Model_Mantissa                 : constant Name_Id := N + 410;
-   Name_Model_Small                    : constant Name_Id := N + 411;
-   Name_Modulus                        : constant Name_Id := N + 412;
-   Name_Null_Parameter                 : constant Name_Id := N + 413; -- GNAT
-   Name_Object_Size                    : constant Name_Id := N + 414; -- GNAT
-   Name_Partition_ID                   : constant Name_Id := N + 415;
-   Name_Passed_By_Reference            : constant Name_Id := N + 416; -- GNAT
-   Name_Pool_Address                   : constant Name_Id := N + 417;
-   Name_Pos                            : constant Name_Id := N + 418;
-   Name_Position                       : constant Name_Id := N + 419;
-   Name_Range                          : constant Name_Id := N + 420;
-   Name_Range_Length                   : constant Name_Id := N + 421; -- GNAT
-   Name_Round                          : constant Name_Id := N + 422;
-   Name_Safe_Emax                      : constant Name_Id := N + 423; -- Ada 83
-   Name_Safe_First                     : constant Name_Id := N + 424;
-   Name_Safe_Large                     : constant Name_Id := N + 425; -- Ada 83
-   Name_Safe_Last                      : constant Name_Id := N + 426;
-   Name_Safe_Small                     : constant Name_Id := N + 427; -- Ada 83
-   Name_Scale                          : constant Name_Id := N + 428;
-   Name_Scaling                        : constant Name_Id := N + 429;
-   Name_Signed_Zeros                   : constant Name_Id := N + 430;
-   Name_Size                           : constant Name_Id := N + 431;
-   Name_Small                          : constant Name_Id := N + 432;
-   Name_Storage_Size                   : constant Name_Id := N + 433;
-   Name_Storage_Unit                   : constant Name_Id := N + 434; -- GNAT
-   Name_Stream_Size                    : constant Name_Id := N + 435; -- Ada 05
-   Name_Tag                            : constant Name_Id := N + 436;
-   Name_Target_Name                    : constant Name_Id := N + 437; -- GNAT
-   Name_Terminated                     : constant Name_Id := N + 438;
-   Name_To_Address                     : constant Name_Id := N + 439; -- GNAT
-   Name_Type_Class                     : constant Name_Id := N + 440; -- GNAT
-   Name_UET_Address                    : constant Name_Id := N + 441; -- GNAT
-   Name_Unbiased_Rounding              : constant Name_Id := N + 442;
-   Name_Unchecked_Access               : constant Name_Id := N + 443;
-   Name_Unconstrained_Array            : constant Name_Id := N + 444;
-   Name_Universal_Literal_String       : constant Name_Id := N + 445; -- GNAT
-   Name_Unrestricted_Access            : constant Name_Id := N + 446; -- GNAT
-   Name_VADS_Size                      : constant Name_Id := N + 447; -- GNAT
-   Name_Val                            : constant Name_Id := N + 448;
-   Name_Valid                          : constant Name_Id := N + 449;
-   Name_Value_Size                     : constant Name_Id := N + 450; -- GNAT
-   Name_Version                        : constant Name_Id := N + 451;
-   Name_Wchar_T_Size                   : constant Name_Id := N + 452; -- GNAT
-   Name_Wide_Wide_Width                : constant Name_Id := N + 453; -- Ada 05
-   Name_Wide_Width                     : constant Name_Id := N + 454;
-   Name_Width                          : constant Name_Id := N + 455;
-   Name_Word_Size                      : constant Name_Id := N + 456; -- GNAT
+   First_Attribute_Name                : constant Name_Id := N + 352;
+   Name_Abort_Signal                   : constant Name_Id := N + 352; -- GNAT
+   Name_Access                         : constant Name_Id := N + 353;
+   Name_Address                        : constant Name_Id := N + 354;
+   Name_Address_Size                   : constant Name_Id := N + 355; -- GNAT
+   Name_Aft                            : constant Name_Id := N + 356;
+   Name_Alignment                      : constant Name_Id := N + 357;
+   Name_Asm_Input                      : constant Name_Id := N + 358; -- GNAT
+   Name_Asm_Output                     : constant Name_Id := N + 359; -- GNAT
+   Name_AST_Entry                      : constant Name_Id := N + 360; -- VMS
+   Name_Bit                            : constant Name_Id := N + 361; -- GNAT
+   Name_Bit_Order                      : constant Name_Id := N + 362;
+   Name_Bit_Position                   : constant Name_Id := N + 363; -- GNAT
+   Name_Body_Version                   : constant Name_Id := N + 364;
+   Name_Callable                       : constant Name_Id := N + 365;
+   Name_Caller                         : constant Name_Id := N + 366;
+   Name_Code_Address                   : constant Name_Id := N + 367; -- GNAT
+   Name_Component_Size                 : constant Name_Id := N + 368;
+   Name_Compose                        : constant Name_Id := N + 369;
+   Name_Constrained                    : constant Name_Id := N + 370;
+   Name_Count                          : constant Name_Id := N + 371;
+   Name_Default_Bit_Order              : constant Name_Id := N + 372; -- GNAT
+   Name_Definite                       : constant Name_Id := N + 373;
+   Name_Delta                          : constant Name_Id := N + 374;
+   Name_Denorm                         : constant Name_Id := N + 375;
+   Name_Digits                         : constant Name_Id := N + 376;
+   Name_Elaborated                     : constant Name_Id := N + 377; -- GNAT
+   Name_Emax                           : constant Name_Id := N + 378; -- Ada 83
+   Name_Enum_Rep                       : constant Name_Id := N + 379; -- GNAT
+   Name_Epsilon                        : constant Name_Id := N + 380; -- Ada 83
+   Name_Exponent                       : constant Name_Id := N + 381;
+   Name_External_Tag                   : constant Name_Id := N + 382;
+   Name_First                          : constant Name_Id := N + 383;
+   Name_First_Bit                      : constant Name_Id := N + 384;
+   Name_Fixed_Value                    : constant Name_Id := N + 385; -- GNAT
+   Name_Fore                           : constant Name_Id := N + 386;
+   Name_Has_Access_Values              : constant Name_Id := N + 387; -- GNAT
+   Name_Has_Discriminants              : constant Name_Id := N + 388; -- GNAT
+   Name_Identity                       : constant Name_Id := N + 389;
+   Name_Img                            : constant Name_Id := N + 390; -- GNAT
+   Name_Integer_Value                  : constant Name_Id := N + 391; -- GNAT
+   Name_Large                          : constant Name_Id := N + 392; -- Ada 83
+   Name_Last                           : constant Name_Id := N + 393;
+   Name_Last_Bit                       : constant Name_Id := N + 394;
+   Name_Leading_Part                   : constant Name_Id := N + 395;
+   Name_Length                         : constant Name_Id := N + 396;
+   Name_Machine_Emax                   : constant Name_Id := N + 397;
+   Name_Machine_Emin                   : constant Name_Id := N + 398;
+   Name_Machine_Mantissa               : constant Name_Id := N + 399;
+   Name_Machine_Overflows              : constant Name_Id := N + 400;
+   Name_Machine_Radix                  : constant Name_Id := N + 401;
+   Name_Machine_Rounding               : constant Name_Id := N + 402; -- Ada 05
+   Name_Machine_Rounds                 : constant Name_Id := N + 403;
+   Name_Machine_Size                   : constant Name_Id := N + 404; -- GNAT
+   Name_Mantissa                       : constant Name_Id := N + 405; -- Ada 83
+   Name_Max_Size_In_Storage_Elements   : constant Name_Id := N + 406;
+   Name_Maximum_Alignment              : constant Name_Id := N + 407; -- GNAT
+   Name_Mechanism_Code                 : constant Name_Id := N + 408; -- GNAT
+   Name_Mod                            : constant Name_Id := N + 409;
+   Name_Model_Emin                     : constant Name_Id := N + 410;
+   Name_Model_Epsilon                  : constant Name_Id := N + 411;
+   Name_Model_Mantissa                 : constant Name_Id := N + 412;
+   Name_Model_Small                    : constant Name_Id := N + 413;
+   Name_Modulus                        : constant Name_Id := N + 414;
+   Name_Null_Parameter                 : constant Name_Id := N + 415; -- GNAT
+   Name_Object_Size                    : constant Name_Id := N + 416; -- GNAT
+   Name_Partition_ID                   : constant Name_Id := N + 417;
+   Name_Passed_By_Reference            : constant Name_Id := N + 418; -- GNAT
+   Name_Pool_Address                   : constant Name_Id := N + 419;
+   Name_Pos                            : constant Name_Id := N + 420;
+   Name_Position                       : constant Name_Id := N + 421;
+   Name_Range                          : constant Name_Id := N + 422;
+   Name_Range_Length                   : constant Name_Id := N + 423; -- GNAT
+   Name_Round                          : constant Name_Id := N + 424;
+   Name_Safe_Emax                      : constant Name_Id := N + 425; -- Ada 83
+   Name_Safe_First                     : constant Name_Id := N + 426;
+   Name_Safe_Large                     : constant Name_Id := N + 427; -- Ada 83
+   Name_Safe_Last                      : constant Name_Id := N + 428;
+   Name_Safe_Small                     : constant Name_Id := N + 429; -- Ada 83
+   Name_Scale                          : constant Name_Id := N + 430;
+   Name_Scaling                        : constant Name_Id := N + 431;
+   Name_Signed_Zeros                   : constant Name_Id := N + 432;
+   Name_Size                           : constant Name_Id := N + 433;
+   Name_Small                          : constant Name_Id := N + 434;
+   Name_Storage_Size                   : constant Name_Id := N + 435;
+   Name_Storage_Unit                   : constant Name_Id := N + 436; -- GNAT
+   Name_Stream_Size                    : constant Name_Id := N + 437; -- Ada 05
+   Name_Tag                            : constant Name_Id := N + 438;
+   Name_Target_Name                    : constant Name_Id := N + 439; -- GNAT
+   Name_Terminated                     : constant Name_Id := N + 440;
+   Name_To_Address                     : constant Name_Id := N + 441; -- GNAT
+   Name_Type_Class                     : constant Name_Id := N + 442; -- GNAT
+   Name_UET_Address                    : constant Name_Id := N + 443; -- GNAT
+   Name_Unbiased_Rounding              : constant Name_Id := N + 444;
+   Name_Unchecked_Access               : constant Name_Id := N + 445;
+   Name_Unconstrained_Array            : constant Name_Id := N + 446;
+   Name_Universal_Literal_String       : constant Name_Id := N + 447; -- GNAT
+   Name_Unrestricted_Access            : constant Name_Id := N + 448; -- GNAT
+   Name_VADS_Size                      : constant Name_Id := N + 449; -- GNAT
+   Name_Val                            : constant Name_Id := N + 450;
+   Name_Valid                          : constant Name_Id := N + 451;
+   Name_Value_Size                     : constant Name_Id := N + 452; -- GNAT
+   Name_Version                        : constant Name_Id := N + 453;
+   Name_Wchar_T_Size                   : constant Name_Id := N + 454; -- GNAT
+   Name_Wide_Wide_Width                : constant Name_Id := N + 455; -- Ada 05
+   Name_Wide_Width                     : constant Name_Id := N + 456;
+   Name_Width                          : constant Name_Id := N + 457;
+   Name_Word_Size                      : constant Name_Id := N + 458; -- GNAT
 
    --  Attributes that designate attributes returning renamable functions,
    --  i.e. functions that return other than a universal value and that
    --  have non-universal arguments.
 
-   First_Renamable_Function_Attribute  : constant Name_Id := N + 457;
-   Name_Adjacent                       : constant Name_Id := N + 457;
-   Name_Ceiling                        : constant Name_Id := N + 458;
-   Name_Copy_Sign                      : constant Name_Id := N + 459;
-   Name_Floor                          : constant Name_Id := N + 460;
-   Name_Fraction                       : constant Name_Id := N + 461;
-   Name_Image                          : constant Name_Id := N + 462;
-   Name_Input                          : constant Name_Id := N + 463;
-   Name_Machine                        : constant Name_Id := N + 464;
-   Name_Max                            : constant Name_Id := N + 465;
-   Name_Min                            : constant Name_Id := N + 466;
-   Name_Model                          : constant Name_Id := N + 467;
-   Name_Pred                           : constant Name_Id := N + 468;
-   Name_Remainder                      : constant Name_Id := N + 469;
-   Name_Rounding                       : constant Name_Id := N + 470;
-   Name_Succ                           : constant Name_Id := N + 471;
-   Name_Truncation                     : constant Name_Id := N + 472;
-   Name_Value                          : constant Name_Id := N + 473;
-   Name_Wide_Image                     : constant Name_Id := N + 474;
-   Name_Wide_Wide_Image                : constant Name_Id := N + 475;
-   Name_Wide_Value                     : constant Name_Id := N + 476;
-   Name_Wide_Wide_Value                : constant Name_Id := N + 477;
-   Last_Renamable_Function_Attribute   : constant Name_Id := N + 477;
+   First_Renamable_Function_Attribute  : constant Name_Id := N + 459;
+   Name_Adjacent                       : constant Name_Id := N + 459;
+   Name_Ceiling                        : constant Name_Id := N + 460;
+   Name_Copy_Sign                      : constant Name_Id := N + 461;
+   Name_Floor                          : constant Name_Id := N + 462;
+   Name_Fraction                       : constant Name_Id := N + 463;
+   Name_Image                          : constant Name_Id := N + 464;
+   Name_Input                          : constant Name_Id := N + 465;
+   Name_Machine                        : constant Name_Id := N + 466;
+   Name_Max                            : constant Name_Id := N + 467;
+   Name_Min                            : constant Name_Id := N + 468;
+   Name_Model                          : constant Name_Id := N + 469;
+   Name_Pred                           : constant Name_Id := N + 470;
+   Name_Remainder                      : constant Name_Id := N + 471;
+   Name_Rounding                       : constant Name_Id := N + 472;
+   Name_Succ                           : constant Name_Id := N + 473;
+   Name_Truncation                     : constant Name_Id := N + 474;
+   Name_Value                          : constant Name_Id := N + 475;
+   Name_Wide_Image                     : constant Name_Id := N + 476;
+   Name_Wide_Wide_Image                : constant Name_Id := N + 477;
+   Name_Wide_Value                     : constant Name_Id := N + 478;
+   Name_Wide_Wide_Value                : constant Name_Id := N + 479;
+   Last_Renamable_Function_Attribute   : constant Name_Id := N + 479;
 
    --  Attributes that designate procedures
 
-   First_Procedure_Attribute           : constant Name_Id := N + 478;
-   Name_Output                         : constant Name_Id := N + 478;
-   Name_Read                           : constant Name_Id := N + 479;
-   Name_Write                          : constant Name_Id := N + 480;
-   Last_Procedure_Attribute            : constant Name_Id := N + 480;
+   First_Procedure_Attribute           : constant Name_Id := N + 480;
+   Name_Output                         : constant Name_Id := N + 480;
+   Name_Read                           : constant Name_Id := N + 481;
+   Name_Write                          : constant Name_Id := N + 482;
+   Last_Procedure_Attribute            : constant Name_Id := N + 482;
 
    --  Remaining attributes are ones that return entities
 
-   First_Entity_Attribute_Name         : constant Name_Id := N + 481;
-   Name_Elab_Body                      : constant Name_Id := N + 481; -- GNAT
-   Name_Elab_Spec                      : constant Name_Id := N + 482; -- GNAT
-   Name_Storage_Pool                   : constant Name_Id := N + 483;
+   First_Entity_Attribute_Name         : constant Name_Id := N + 483;
+   Name_Elab_Body                      : constant Name_Id := N + 483; -- GNAT
+   Name_Elab_Spec                      : constant Name_Id := N + 484; -- GNAT
+   Name_Storage_Pool                   : constant Name_Id := N + 485;
 
    --  These attributes are the ones that return types
 
-   First_Type_Attribute_Name           : constant Name_Id := N + 484;
-   Name_Base                           : constant Name_Id := N + 484;
-   Name_Class                          : constant Name_Id := N + 485;
-   Last_Type_Attribute_Name            : constant Name_Id := N + 485;
-   Last_Entity_Attribute_Name          : constant Name_Id := N + 485;
-   Last_Attribute_Name                 : constant Name_Id := N + 485;
+   First_Type_Attribute_Name           : constant Name_Id := N + 486;
+   Name_Base                           : constant Name_Id := N + 486;
+   Name_Class                          : constant Name_Id := N + 487;
+   Last_Type_Attribute_Name            : constant Name_Id := N + 487;
+   Last_Entity_Attribute_Name          : constant Name_Id := N + 487;
+   Last_Attribute_Name                 : constant Name_Id := N + 487;
 
    --  Names of recognized locking policy identifiers
 
@@ -791,10 +797,10 @@ package Snames is
    --  name (e.g. C for Ceiling_Locking). If new policy names are added,
    --  the first character must be distinct.
 
-   First_Locking_Policy_Name           : constant Name_Id := N + 486;
-   Name_Ceiling_Locking                : constant Name_Id := N + 486;
-   Name_Inheritance_Locking            : constant Name_Id := N + 487;
-   Last_Locking_Policy_Name            : constant Name_Id := N + 487;
+   First_Locking_Policy_Name           : constant Name_Id := N + 488;
+   Name_Ceiling_Locking                : constant Name_Id := N + 488;
+   Name_Inheritance_Locking            : constant Name_Id := N + 489;
+   Last_Locking_Policy_Name            : constant Name_Id := N + 489;
 
    --  Names of recognized queuing policy identifiers
 
@@ -802,10 +808,10 @@ package Snames is
    --  name (e.g. F for FIFO_Queuing). If new policy names are added,
    --  the first character must be distinct.
 
-   First_Queuing_Policy_Name           : constant Name_Id := N + 488;
-   Name_FIFO_Queuing                   : constant Name_Id := N + 488;
-   Name_Priority_Queuing               : constant Name_Id := N + 489;
-   Last_Queuing_Policy_Name            : constant Name_Id := N + 489;
+   First_Queuing_Policy_Name           : constant Name_Id := N + 490;
+   Name_FIFO_Queuing                   : constant Name_Id := N + 490;
+   Name_Priority_Queuing               : constant Name_Id := N + 491;
+   Last_Queuing_Policy_Name            : constant Name_Id := N + 491;
 
    --  Names of recognized task dispatching policy identifiers
 
@@ -813,215 +819,220 @@ package Snames is
    --  name (e.g. F for FIFO_WIthinn_Priorities). If new policy names
    --  are added, the first character must be distinct.
 
-   First_Task_Dispatching_Policy_Name  : constant Name_Id := N + 490;
-   Name_FIFO_Within_Priorities         : constant Name_Id := N + 490;
-   Last_Task_Dispatching_Policy_Name   : constant Name_Id := N + 490;
+   First_Task_Dispatching_Policy_Name  : constant Name_Id := N + 492;
+   Name_FIFO_Within_Priorities         : constant Name_Id := N + 492;
+   Last_Task_Dispatching_Policy_Name   : constant Name_Id := N + 492;
 
    --  Names of recognized checks for pragma Suppress
 
-   First_Check_Name                    : constant Name_Id := N + 491;
-   Name_Access_Check                   : constant Name_Id := N + 491;
-   Name_Accessibility_Check            : constant Name_Id := N + 492;
-   Name_Discriminant_Check             : constant Name_Id := N + 493;
-   Name_Division_Check                 : constant Name_Id := N + 494;
-   Name_Elaboration_Check              : constant Name_Id := N + 495;
-   Name_Index_Check                    : constant Name_Id := N + 496;
-   Name_Length_Check                   : constant Name_Id := N + 497;
-   Name_Overflow_Check                 : constant Name_Id := N + 498;
-   Name_Range_Check                    : constant Name_Id := N + 499;
-   Name_Storage_Check                  : constant Name_Id := N + 500;
-   Name_Tag_Check                      : constant Name_Id := N + 501;
-   Name_All_Checks                     : constant Name_Id := N + 502;
-   Last_Check_Name                     : constant Name_Id := N + 502;
+   First_Check_Name                    : constant Name_Id := N + 493;
+   Name_Access_Check                   : constant Name_Id := N + 493;
+   Name_Accessibility_Check            : constant Name_Id := N + 494;
+   Name_Discriminant_Check             : constant Name_Id := N + 495;
+   Name_Division_Check                 : constant Name_Id := N + 496;
+   Name_Elaboration_Check              : constant Name_Id := N + 497;
+   Name_Index_Check                    : constant Name_Id := N + 498;
+   Name_Length_Check                   : constant Name_Id := N + 499;
+   Name_Overflow_Check                 : constant Name_Id := N + 500;
+   Name_Range_Check                    : constant Name_Id := N + 501;
+   Name_Storage_Check                  : constant Name_Id := N + 502;
+   Name_Tag_Check                      : constant Name_Id := N + 503;
+   Name_All_Checks                     : constant Name_Id := N + 504;
+   Last_Check_Name                     : constant Name_Id := N + 504;
 
    --  Names corresponding to reserved keywords, excluding those already
    --  declared in the attribute list (Access, Delta, Digits, Mod, Range).
 
-   Name_Abort                          : constant Name_Id := N + 503;
-   Name_Abs                            : constant Name_Id := N + 504;
-   Name_Accept                         : constant Name_Id := N + 505;
-   Name_And                            : constant Name_Id := N + 506;
-   Name_All                            : constant Name_Id := N + 507;
-   Name_Array                          : constant Name_Id := N + 508;
-   Name_At                             : constant Name_Id := N + 509;
-   Name_Begin                          : constant Name_Id := N + 510;
-   Name_Body                           : constant Name_Id := N + 511;
-   Name_Case                           : constant Name_Id := N + 512;
-   Name_Constant                       : constant Name_Id := N + 513;
-   Name_Declare                        : constant Name_Id := N + 514;
-   Name_Delay                          : constant Name_Id := N + 515;
-   Name_Do                             : constant Name_Id := N + 516;
-   Name_Else                           : constant Name_Id := N + 517;
-   Name_Elsif                          : constant Name_Id := N + 518;
-   Name_End                            : constant Name_Id := N + 519;
-   Name_Entry                          : constant Name_Id := N + 520;
-   Name_Exception                      : constant Name_Id := N + 521;
-   Name_Exit                           : constant Name_Id := N + 522;
-   Name_For                            : constant Name_Id := N + 523;
-   Name_Function                       : constant Name_Id := N + 524;
-   Name_Generic                        : constant Name_Id := N + 525;
-   Name_Goto                           : constant Name_Id := N + 526;
-   Name_If                             : constant Name_Id := N + 527;
-   Name_In                             : constant Name_Id := N + 528;
-   Name_Is                             : constant Name_Id := N + 529;
-   Name_Limited                        : constant Name_Id := N + 530;
-   Name_Loop                           : constant Name_Id := N + 531;
-   Name_New                            : constant Name_Id := N + 532;
-   Name_Not                            : constant Name_Id := N + 533;
-   Name_Null                           : constant Name_Id := N + 534;
-   Name_Of                             : constant Name_Id := N + 535;
-   Name_Or                             : constant Name_Id := N + 536;
-   Name_Others                         : constant Name_Id := N + 537;
-   Name_Out                            : constant Name_Id := N + 538;
-   Name_Package                        : constant Name_Id := N + 539;
-   Name_Pragma                         : constant Name_Id := N + 540;
-   Name_Private                        : constant Name_Id := N + 541;
-   Name_Procedure                      : constant Name_Id := N + 542;
-   Name_Raise                          : constant Name_Id := N + 543;
-   Name_Record                         : constant Name_Id := N + 544;
-   Name_Rem                            : constant Name_Id := N + 545;
-   Name_Renames                        : constant Name_Id := N + 546;
-   Name_Return                         : constant Name_Id := N + 547;
-   Name_Reverse                        : constant Name_Id := N + 548;
-   Name_Select                         : constant Name_Id := N + 549;
-   Name_Separate                       : constant Name_Id := N + 550;
-   Name_Subtype                        : constant Name_Id := N + 551;
-   Name_Task                           : constant Name_Id := N + 552;
-   Name_Terminate                      : constant Name_Id := N + 553;
-   Name_Then                           : constant Name_Id := N + 554;
-   Name_Type                           : constant Name_Id := N + 555;
-   Name_Use                            : constant Name_Id := N + 556;
-   Name_When                           : constant Name_Id := N + 557;
-   Name_While                          : constant Name_Id := N + 558;
-   Name_With                           : constant Name_Id := N + 559;
-   Name_Xor                            : constant Name_Id := N + 560;
+   Name_Abort                          : constant Name_Id := N + 505;
+   Name_Abs                            : constant Name_Id := N + 506;
+   Name_Accept                         : constant Name_Id := N + 507;
+   Name_And                            : constant Name_Id := N + 508;
+   Name_All                            : constant Name_Id := N + 509;
+   Name_Array                          : constant Name_Id := N + 510;
+   Name_At                             : constant Name_Id := N + 511;
+   Name_Begin                          : constant Name_Id := N + 512;
+   Name_Body                           : constant Name_Id := N + 513;
+   Name_Case                           : constant Name_Id := N + 514;
+   Name_Constant                       : constant Name_Id := N + 515;
+   Name_Declare                        : constant Name_Id := N + 516;
+   Name_Delay                          : constant Name_Id := N + 517;
+   Name_Do                             : constant Name_Id := N + 518;
+   Name_Else                           : constant Name_Id := N + 519;
+   Name_Elsif                          : constant Name_Id := N + 520;
+   Name_End                            : constant Name_Id := N + 521;
+   Name_Entry                          : constant Name_Id := N + 522;
+   Name_Exception                      : constant Name_Id := N + 523;
+   Name_Exit                           : constant Name_Id := N + 524;
+   Name_For                            : constant Name_Id := N + 525;
+   Name_Function                       : constant Name_Id := N + 526;
+   Name_Generic                        : constant Name_Id := N + 527;
+   Name_Goto                           : constant Name_Id := N + 528;
+   Name_If                             : constant Name_Id := N + 529;
+   Name_In                             : constant Name_Id := N + 530;
+   Name_Is                             : constant Name_Id := N + 531;
+   Name_Limited                        : constant Name_Id := N + 532;
+   Name_Loop                           : constant Name_Id := N + 533;
+   Name_New                            : constant Name_Id := N + 534;
+   Name_Not                            : constant Name_Id := N + 535;
+   Name_Null                           : constant Name_Id := N + 536;
+   Name_Of                             : constant Name_Id := N + 537;
+   Name_Or                             : constant Name_Id := N + 538;
+   Name_Others                         : constant Name_Id := N + 539;
+   Name_Out                            : constant Name_Id := N + 540;
+   Name_Package                        : constant Name_Id := N + 541;
+   Name_Pragma                         : constant Name_Id := N + 542;
+   Name_Private                        : constant Name_Id := N + 543;
+   Name_Procedure                      : constant Name_Id := N + 544;
+   Name_Raise                          : constant Name_Id := N + 545;
+   Name_Record                         : constant Name_Id := N + 546;
+   Name_Rem                            : constant Name_Id := N + 547;
+   Name_Renames                        : constant Name_Id := N + 548;
+   Name_Return                         : constant Name_Id := N + 549;
+   Name_Reverse                        : constant Name_Id := N + 550;
+   Name_Select                         : constant Name_Id := N + 551;
+   Name_Separate                       : constant Name_Id := N + 552;
+   Name_Subtype                        : constant Name_Id := N + 553;
+   Name_Task                           : constant Name_Id := N + 554;
+   Name_Terminate                      : constant Name_Id := N + 555;
+   Name_Then                           : constant Name_Id := N + 556;
+   Name_Type                           : constant Name_Id := N + 557;
+   Name_Use                            : constant Name_Id := N + 558;
+   Name_When                           : constant Name_Id := N + 559;
+   Name_While                          : constant Name_Id := N + 560;
+   Name_With                           : constant Name_Id := N + 561;
+   Name_Xor                            : constant Name_Id := N + 562;
 
    --  Names of intrinsic subprograms
 
    --  Note: Asm is missing from this list, since Asm is a legitimate
    --  convention name. So is To_Adress, which is a GNAT attribute.
 
-   First_Intrinsic_Name                 : constant Name_Id := N + 561;
-   Name_Divide                          : constant Name_Id := N + 561;
-   Name_Enclosing_Entity                : constant Name_Id := N + 562;
-   Name_Exception_Information           : constant Name_Id := N + 563;
-   Name_Exception_Message               : constant Name_Id := N + 564;
-   Name_Exception_Name                  : constant Name_Id := N + 565;
-   Name_File                            : constant Name_Id := N + 566;
-   Name_Generic_Dispatching_Constructor : constant Name_Id := N + 567;
-   Name_Import_Address                  : constant Name_Id := N + 568;
-   Name_Import_Largest_Value            : constant Name_Id := N + 569;
-   Name_Import_Value                    : constant Name_Id := N + 570;
-   Name_Is_Negative                     : constant Name_Id := N + 571;
-   Name_Line                            : constant Name_Id := N + 572;
-   Name_Rotate_Left                     : constant Name_Id := N + 573;
-   Name_Rotate_Right                    : constant Name_Id := N + 574;
-   Name_Shift_Left                      : constant Name_Id := N + 575;
-   Name_Shift_Right                     : constant Name_Id := N + 576;
-   Name_Shift_Right_Arithmetic          : constant Name_Id := N + 577;
-   Name_Source_Location                 : constant Name_Id := N + 578;
-   Name_Unchecked_Conversion            : constant Name_Id := N + 579;
-   Name_Unchecked_Deallocation          : constant Name_Id := N + 580;
-   Name_To_Pointer                      : constant Name_Id := N + 581;
-   Last_Intrinsic_Name                  : constant Name_Id := N + 581;
+   First_Intrinsic_Name                 : constant Name_Id := N + 563;
+   Name_Divide                          : constant Name_Id := N + 563;
+   Name_Enclosing_Entity                : constant Name_Id := N + 564;
+   Name_Exception_Information           : constant Name_Id := N + 565;
+   Name_Exception_Message               : constant Name_Id := N + 566;
+   Name_Exception_Name                  : constant Name_Id := N + 567;
+   Name_File                            : constant Name_Id := N + 568;
+   Name_Generic_Dispatching_Constructor : constant Name_Id := N + 569;
+   Name_Import_Address                  : constant Name_Id := N + 570;
+   Name_Import_Largest_Value            : constant Name_Id := N + 571;
+   Name_Import_Value                    : constant Name_Id := N + 572;
+   Name_Is_Negative                     : constant Name_Id := N + 573;
+   Name_Line                            : constant Name_Id := N + 574;
+   Name_Rotate_Left                     : constant Name_Id := N + 575;
+   Name_Rotate_Right                    : constant Name_Id := N + 576;
+   Name_Shift_Left                      : constant Name_Id := N + 577;
+   Name_Shift_Right                     : constant Name_Id := N + 578;
+   Name_Shift_Right_Arithmetic          : constant Name_Id := N + 579;
+   Name_Source_Location                 : constant Name_Id := N + 580;
+   Name_Unchecked_Conversion            : constant Name_Id := N + 581;
+   Name_Unchecked_Deallocation          : constant Name_Id := N + 582;
+   Name_To_Pointer                      : constant Name_Id := N + 583;
+   Last_Intrinsic_Name                  : constant Name_Id := N + 583;
+
+   --  Names used in processing intrinsic calls
+
+   Name_Free                           : constant Name_Id := N + 584;
 
    --  Reserved words used only in Ada 95
 
-   First_95_Reserved_Word              : constant Name_Id := N + 582;
-   Name_Abstract                       : constant Name_Id := N + 582;
-   Name_Aliased                        : constant Name_Id := N + 583;
-   Name_Protected                      : constant Name_Id := N + 584;
-   Name_Until                          : constant Name_Id := N + 585;
-   Name_Requeue                        : constant Name_Id := N + 586;
-   Name_Tagged                         : constant Name_Id := N + 587;
-   Last_95_Reserved_Word               : constant Name_Id := N + 587;
+   First_95_Reserved_Word              : constant Name_Id := N + 585;
+   Name_Abstract                       : constant Name_Id := N + 585;
+   Name_Aliased                        : constant Name_Id := N + 586;
+   Name_Protected                      : constant Name_Id := N + 587;
+   Name_Until                          : constant Name_Id := N + 588;
+   Name_Requeue                        : constant Name_Id := N + 589;
+   Name_Tagged                         : constant Name_Id := N + 590;
+   Last_95_Reserved_Word               : constant Name_Id := N + 590;
 
    subtype Ada_95_Reserved_Words is
      Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
 
    --  Miscellaneous names used in semantic checking
 
-   Name_Raise_Exception                : constant Name_Id := N + 588;
+   Name_Raise_Exception                : constant Name_Id := N + 591;
 
    --  Additional reserved words and identifiers used in GNAT Project Files
    --  Note that Name_External is already previously declared
 
-   Name_Ada_Roots                      : constant Name_Id := N + 589;
-   Name_Binder                         : constant Name_Id := N + 590;
-   Name_Binder_Driver                  : constant Name_Id := N + 591;
-   Name_Body_Suffix                    : constant Name_Id := N + 592;
-   Name_Builder                        : constant Name_Id := N + 593;
-   Name_Compiler                       : constant Name_Id := N + 594;
-   Name_Compiler_Driver                : constant Name_Id := N + 595;
-   Name_Compiler_Kind                  : constant Name_Id := N + 596;
-   Name_Compute_Dependency             : constant Name_Id := N + 597;
-   Name_Cross_Reference                : constant Name_Id := N + 598;
-   Name_Default_Linker                 : constant Name_Id := N + 599;
-   Name_Default_Switches               : constant Name_Id := N + 600;
-   Name_Dependency_Option              : constant Name_Id := N + 601;
-   Name_Exec_Dir                       : constant Name_Id := N + 602;
-   Name_Executable                     : constant Name_Id := N + 603;
-   Name_Executable_Suffix              : constant Name_Id := N + 604;
-   Name_Extends                        : constant Name_Id := N + 605;
-   Name_Externally_Built               : constant Name_Id := N + 606;
-   Name_Finder                         : constant Name_Id := N + 607;
-   Name_Global_Configuration_Pragmas   : constant Name_Id := N + 608;
-   Name_Gnatls                         : constant Name_Id := N + 609;
-   Name_Gnatstub                       : constant Name_Id := N + 610;
-   Name_Implementation                 : constant Name_Id := N + 611;
-   Name_Implementation_Exceptions      : constant Name_Id := N + 612;
-   Name_Implementation_Suffix          : constant Name_Id := N + 613;
-   Name_Include_Option                 : constant Name_Id := N + 614;
-   Name_Language_Processing            : constant Name_Id := N + 615;
-   Name_Languages                      : constant Name_Id := N + 616;
-   Name_Library_Dir                    : constant Name_Id := N + 617;
-   Name_Library_Auto_Init              : constant Name_Id := N + 618;
-   Name_Library_GCC                    : constant Name_Id := N + 619;
-   Name_Library_Interface              : constant Name_Id := N + 620;
-   Name_Library_Kind                   : constant Name_Id := N + 621;
-   Name_Library_Name                   : constant Name_Id := N + 622;
-   Name_Library_Options                : constant Name_Id := N + 623;
-   Name_Library_Reference_Symbol_File  : constant Name_Id := N + 624;
-   Name_Library_Src_Dir                : constant Name_Id := N + 625;
-   Name_Library_Symbol_File            : constant Name_Id := N + 626;
-   Name_Library_Symbol_Policy          : constant Name_Id := N + 627;
-   Name_Library_Version                : constant Name_Id := N + 628;
-   Name_Linker                         : constant Name_Id := N + 629;
-   Name_Local_Configuration_Pragmas    : constant Name_Id := N + 630;
-   Name_Locally_Removed_Files          : constant Name_Id := N + 631;
-   Name_Metrics                        : constant Name_Id := N + 632;
-   Name_Naming                         : constant Name_Id := N + 633;
-   Name_Object_Dir                     : constant Name_Id := N + 634;
-   Name_Pretty_Printer                 : constant Name_Id := N + 635;
-   Name_Project                        : constant Name_Id := N + 636;
-   Name_Separate_Suffix                : constant Name_Id := N + 637;
-   Name_Source_Dirs                    : constant Name_Id := N + 638;
-   Name_Source_Files                   : constant Name_Id := N + 639;
-   Name_Source_List_File               : constant Name_Id := N + 640;
-   Name_Spec                           : constant Name_Id := N + 641;
-   Name_Spec_Suffix                    : constant Name_Id := N + 642;
-   Name_Specification                  : constant Name_Id := N + 643;
-   Name_Specification_Exceptions       : constant Name_Id := N + 644;
-   Name_Specification_Suffix           : constant Name_Id := N + 645;
-   Name_Switches                       : constant Name_Id := N + 646;
+   Name_Ada_Roots                      : constant Name_Id := N + 592;
+   Name_Binder                         : constant Name_Id := N + 593;
+   Name_Binder_Driver                  : constant Name_Id := N + 594;
+   Name_Body_Suffix                    : constant Name_Id := N + 595;
+   Name_Builder                        : constant Name_Id := N + 596;
+   Name_Compiler                       : constant Name_Id := N + 597;
+   Name_Compiler_Driver                : constant Name_Id := N + 598;
+   Name_Compiler_Kind                  : constant Name_Id := N + 599;
+   Name_Compute_Dependency             : constant Name_Id := N + 600;
+   Name_Cross_Reference                : constant Name_Id := N + 601;
+   Name_Default_Linker                 : constant Name_Id := N + 602;
+   Name_Default_Switches               : constant Name_Id := N + 603;
+   Name_Dependency_Option              : constant Name_Id := N + 604;
+   Name_Exec_Dir                       : constant Name_Id := N + 605;
+   Name_Executable                     : constant Name_Id := N + 606;
+   Name_Executable_Suffix              : constant Name_Id := N + 607;
+   Name_Extends                        : constant Name_Id := N + 608;
+   Name_Externally_Built               : constant Name_Id := N + 609;
+   Name_Finder                         : constant Name_Id := N + 610;
+   Name_Global_Configuration_Pragmas   : constant Name_Id := N + 611;
+   Name_Gnatls                         : constant Name_Id := N + 612;
+   Name_Gnatstub                       : constant Name_Id := N + 613;
+   Name_Implementation                 : constant Name_Id := N + 614;
+   Name_Implementation_Exceptions      : constant Name_Id := N + 615;
+   Name_Implementation_Suffix          : constant Name_Id := N + 616;
+   Name_Include_Option                 : constant Name_Id := N + 617;
+   Name_Language_Processing            : constant Name_Id := N + 618;
+   Name_Languages                      : constant Name_Id := N + 619;
+   Name_Library_Ali_Dir                : constant Name_Id := N + 620;
+   Name_Library_Dir                    : constant Name_Id := N + 621;
+   Name_Library_Auto_Init              : constant Name_Id := N + 622;
+   Name_Library_GCC                    : constant Name_Id := N + 623;
+   Name_Library_Interface              : constant Name_Id := N + 624;
+   Name_Library_Kind                   : constant Name_Id := N + 625;
+   Name_Library_Name                   : constant Name_Id := N + 626;
+   Name_Library_Options                : constant Name_Id := N + 627;
+   Name_Library_Reference_Symbol_File  : constant Name_Id := N + 628;
+   Name_Library_Src_Dir                : constant Name_Id := N + 629;
+   Name_Library_Symbol_File            : constant Name_Id := N + 630;
+   Name_Library_Symbol_Policy          : constant Name_Id := N + 631;
+   Name_Library_Version                : constant Name_Id := N + 632;
+   Name_Linker                         : constant Name_Id := N + 633;
+   Name_Local_Configuration_Pragmas    : constant Name_Id := N + 634;
+   Name_Locally_Removed_Files          : constant Name_Id := N + 635;
+   Name_Metrics                        : constant Name_Id := N + 636;
+   Name_Naming                         : constant Name_Id := N + 637;
+   Name_Object_Dir                     : constant Name_Id := N + 638;
+   Name_Pretty_Printer                 : constant Name_Id := N + 639;
+   Name_Project                        : constant Name_Id := N + 640;
+   Name_Separate_Suffix                : constant Name_Id := N + 641;
+   Name_Source_Dirs                    : constant Name_Id := N + 642;
+   Name_Source_Files                   : constant Name_Id := N + 643;
+   Name_Source_List_File               : constant Name_Id := N + 644;
+   Name_Spec                           : constant Name_Id := N + 645;
+   Name_Spec_Suffix                    : constant Name_Id := N + 646;
+   Name_Specification                  : constant Name_Id := N + 647;
+   Name_Specification_Exceptions       : constant Name_Id := N + 648;
+   Name_Specification_Suffix           : constant Name_Id := N + 649;
+   Name_Switches                       : constant Name_Id := N + 650;
 
    --  Other miscellaneous names used in front end
 
-   Name_Unaligned_Valid                : constant Name_Id := N + 647;
+   Name_Unaligned_Valid                : constant Name_Id := N + 651;
 
    --  ----------------------------------------------------------------
-   First_2005_Reserved_Word            : constant Name_Id := N + 648;
-   Name_Interface                      : constant Name_Id := N + 648;
-   Name_Overriding                     : constant Name_Id := N + 649;
-   Name_Synchronized                   : constant Name_Id := N + 650;
-   Last_2005_Reserved_Word             : constant Name_Id := N + 650;
+   First_2005_Reserved_Word            : constant Name_Id := N + 652;
+   Name_Interface                      : constant Name_Id := N + 652;
+   Name_Overriding                     : constant Name_Id := N + 653;
+   Name_Synchronized                   : constant Name_Id := N + 654;
+   Last_2005_Reserved_Word             : constant Name_Id := N + 654;
 
    subtype Ada_2005_Reserved_Words is
      Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word;
 
    --  Mark last defined name for consistency check in Snames body
 
-   Last_Predefined_Name                : constant Name_Id := N + 650;
+   Last_Predefined_Name                : constant Name_Id := N + 654;
 
    subtype Any_Operator_Name is Name_Id range
      First_Operator_Name .. Last_Operator_Name;
@@ -1081,6 +1092,7 @@ package Snames is
       Attribute_Machine_Mantissa,
       Attribute_Machine_Overflows,
       Attribute_Machine_Radix,
+      Attribute_Machine_Rounding,
       Attribute_Machine_Rounds,
       Attribute_Machine_Size,
       Attribute_Mantissa,