a-tags.adb (Register_Interface_Offset): New subprogram.

2008-04-08  Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* a-tags.adb (Register_Interface_Offset): New subprogram.
	(Set_Dynamic_Offset_To_Top): New subprogram (see previous comment).
	(To_Predef_Prims_Table_Ptr): Removed.
	(Acc_Size): Removed.
	(To_Acc_Size): Removed.
	(Parent_Size): Modified to the call the subprogram returning the size of
	the parent by means of the new TSD component Size_Func.

	* a-tags.ads (Offset_To_Top_Ptr): New access type declaration.
	(DT_Offset_To_Top_Offset): New constant value that is used to generate
	code referencing the Offset_To_Top component of the dispatch table's
	prologue.
	(Prim_Ptr): New declaration of access to procedure. Used to avoid the
	use of 'address to initialize dispatch table slots.
	(Size_Func): New component of the TSD. Used by the run-time to call the
	size primitive of the tagged type.

	* checks.adb (Apply_Access_Check): Avoid check when accessing the
	Offset_To_Top component of a dispatch table.
	(Null_Exclusion_Static_Checks): If the non-null access type appears in a
	deferred constant declaration. do not add a null expression, to prevent
	spurious errors when full declaration is analyzed.
	(Apply_Discriminant_Check): If both discriminant constraints share a
	node which is not static but has no side effects, do not generate a
	check for that discriminant.
	(Generate_Index_Checks): Set Name_Req to true in call to duplicate
	subexpr, since the prefix of an attribute is a name.

	* checks.ads: Fix nit in comment.

	* exp_ch3.ads, exp_ch3.adb (Freeze_Record_Type): Do not add the spec
	and body of predefined primitives in case of CPP tagged type
	derivations.
	(Freeze_Type): Deal properly with no storage pool case
	(Make_Predefined_Primitive_Specs): Generate specification of abstract
	primitive Deep_Adjust if a nonlimited interface is derived from a
	limited interface.
	(Build_Dcheck_Functions): Create discriminant-checking functions only
	for variants that have some component(s).
	(Build_Slice_Assignment): In expanded code for slice assignment, handle
	properly the case where the slice bounds extend to the last value of the
	underlying representation.
	(Get_Simple_Init_Val): New calling sequence, accomodate Invalid_Value
	(Is_Variable_Size_Record): An array component has a static size if
	index bounds are enumeration literals.

	* exp_disp.adb (Make_DT): Use the first subtype to determine whether
	an external tag has been specified for the type.
	(Building_Static_DT): Add missing support for private types.
	(Make_DT): Add declaration of Parent_Typ to ensure consistent access
	to the entity associated with the parent of Typ. This is done to
	avoid wrong access when the parent is a private type.
	(Expand_Interface_Conversion): Improve error message when the
	configurable runtime has no support for dynamic interface conversion.
	(Expand_Interface_Thunk): Add missing support to interface types in
	configurable runtime.
	(Expand_Dispatching_Call): remove obsolete code.
	(Make_DT): Replace occurrences of RE_Address by RE_Prim_Ptr, and
	ensure that all subtypes and aggregates associated with dispatch
	tables have the attribute Is_Dispatch_Table_Entity set to true.
	(Register_Primitive): Rename one variable to improve code reading.
	Replace occurrences of RE_Addres by RE_Prim_Ptr. Register copy o
	of the pointer to the 'size primitive in the TSD.

	* rtsfind.ads (RE_DT_Offset_To_Top_Offset): New entity.
	(RE_Offset_To_Top_Ptr): New entity.
	(RE_Register_Interface_Offset): New entity.
	(RE_Set_Dynamic_Offset_To_Top): New entity.
	(RE_Set_Offset_To_Top): Removed entity.
	(RE_Prim_Ptr): New entity
	(RE_Size_Func): New entity
	(RE_Size_Ptr): New entity
	(RTU_Id): Add Ada_Dispatching and Ada_Dispatching_EDF.
	(Ada_Dispatching_Child): Define this new subrange.
	(RE_Id): Add new required run-time calls (RE_Set_Deadline, RE_Clock,
	 RE_Time_Span, and RE_Time_Span_Zero).
	(RE_Unit_Table): Add new required run-time calls

	* rtsfind.adb (Get_Unit_Name): Add processing for Ada.Dispatching
	children.

	* exp_atag.ads, exp_atag.adb (Build_Offset_To_Top): New subprogram.
	(Build_Set_Static_Offset_To_Top): New subprogram. Generates code that
	 initializes the Offset_To_Top component of a dispatch table.
	(Build_Predef_Prims): Removed.
	(Build_Get_Predefined_Prim_Op_Address): Replace call to Predef_Prims by
	 its actual code.
	(Build_Set_Size_Function): New subprogram.

	* exp_ch13.adb: Do not generate storage variable for storage_size zero
	(Expand): Handle setting/restoring flag Inside_Freezing_Actions

From-SVN: r134020

gcc/ada/a-tags.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -105,25 +105,12 @@ package body Ada.Tags is
    function To_Object_Specific_Data_Ptr is
      new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr);
 
-   function To_Predef_Prims_Table_Ptr is
-     new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr);
-
    function To_Tag_Ptr is
      new Ada.Unchecked_Conversion (System.Address, Tag_Ptr);
 
    function To_Type_Specific_Data_Ptr is
      new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr);
 
-   ------------------------------------------------
-   -- Unchecked Conversions for other components --
-   ------------------------------------------------
-
-   type Acc_Size
-     is access function (A : System.Address) return Long_Long_Integer;
-
-   function To_Acc_Size is new Unchecked_Conversion (System.Address, Acc_Size);
-   --  The profile of the implicitly defined _size primitive
-
    -------------------------------
    -- Inline_Always Subprograms --
    -------------------------------
@@ -733,7 +720,7 @@ package body Ada.Tags is
 
    begin
       Len := 1;
-      while Str (Len) /= ASCII.Nul loop
+      while Str (Len) /= ASCII.NUL loop
          Len := Len + 1;
       end loop;
 
@@ -778,10 +765,6 @@ package body Ada.Tags is
       --  The tag of the parent is always in the first slot of the table of
       --  ancestor tags.
 
-      Size_Slot : constant Positive := 1;
-      --  The pointer to the _size primitive is always in the first slot of
-      --  the dispatch table.
-
       TSD_Ptr : constant Addr_Ptr :=
                   To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
       TSD     : constant Type_Specific_Data_Ptr :=
@@ -789,24 +772,16 @@ package body Ada.Tags is
       --  Pointer to the TSD
 
       Parent_Tag     : constant Tag := TSD.Tags_Table (Parent_Slot);
-      Parent_Predef_Prims_Ptr : constant Addr_Ptr :=
+      Parent_TSD_Ptr : constant Addr_Ptr :=
                          To_Addr_Ptr (To_Address (Parent_Tag)
-                                                - DT_Predef_Prims_Offset);
-      Parent_Predef_Prims     : constant Predef_Prims_Table_Ptr :=
-                                  To_Predef_Prims_Table_Ptr
-                                    (Parent_Predef_Prims_Ptr.all);
-
-      --  The tag of the parent type through the dispatch table and its
-      --  Predef_Prims field.
-
-      F : constant Acc_Size :=
-            To_Acc_Size (Parent_Predef_Prims (Size_Slot));
-      --  Access to the _size primitive of the parent
+                                       - DT_Typeinfo_Ptr_Size);
+      Parent_TSD     : constant Type_Specific_Data_Ptr :=
+                         To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all);
 
    begin
       --  Here we compute the size of the _parent field of the object
 
-      return SSE.Storage_Count (F.all (Obj));
+      return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj));
    end Parent_Size;
 
    ----------------
@@ -837,6 +812,56 @@ package body Ada.Tags is
       end if;
    end Parent_Tag;
 
+   -------------------------------
+   -- Register_Interface_Offset --
+   -------------------------------
+
+   procedure Register_Interface_Offset
+     (This         : System.Address;
+      Interface_T  : Tag;
+      Is_Static    : Boolean;
+      Offset_Value : SSE.Storage_Offset;
+      Offset_Func  : Offset_To_Top_Function_Ptr)
+   is
+      Prim_DT     : Dispatch_Table_Ptr;
+      Iface_Table : Interface_Data_Ptr;
+
+   begin
+      --  "This" points to the primary DT and we must save Offset_Value in
+      --  the Offset_To_Top field of the corresponding dispatch table.
+
+      Prim_DT     := DT (To_Tag_Ptr (This).all);
+      Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
+
+      --  Save Offset_Value in the table of interfaces of the primary DT.
+      --  This data will be used by the subprogram "Displace" to give support
+      --  to backward abstract interface type conversions.
+
+      --  Register the offset in the table of interfaces
+
+      if Iface_Table /= null then
+         for Id in 1 .. Iface_Table.Nb_Ifaces loop
+            if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
+               if Is_Static or else Offset_Value = 0 then
+                  Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
+                  Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
+                    Offset_Value;
+               else
+                  Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
+                  Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
+                    Offset_Func;
+               end if;
+
+               return;
+            end if;
+         end loop;
+      end if;
+
+      --  If we arrive here there is some error in the run-time data structure
+
+      raise Program_Error;
+   end Register_Interface_Offset;
+
    ------------------
    -- Register_Tag --
    ------------------
@@ -892,68 +917,26 @@ package body Ada.Tags is
    -- Set_Offset_To_Top --
    -----------------------
 
-   procedure Set_Offset_To_Top
+   procedure Set_Dynamic_Offset_To_Top
      (This         : System.Address;
       Interface_T  : Tag;
-      Is_Static    : Boolean;
       Offset_Value : SSE.Storage_Offset;
       Offset_Func  : Offset_To_Top_Function_Ptr)
    is
-      Prim_DT     : Dispatch_Table_Ptr;
       Sec_Base : System.Address;
       Sec_DT   : Dispatch_Table_Ptr;
-      Iface_Table : Interface_Data_Ptr;
-
    begin
       --  Save the offset to top field in the secondary dispatch table
 
       if Offset_Value /= 0 then
          Sec_Base := This + Offset_Value;
          Sec_DT := DT (To_Tag_Ptr (Sec_Base).all);
-
-         if Is_Static then
-            Sec_DT.Offset_To_Top := Offset_Value;
-         else
          Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last;
       end if;
-      end if;
-
-      --  "This" points to the primary DT and we must save Offset_Value in
-      --  the Offset_To_Top field of the corresponding secondary dispatch
-      --  table.
-
-      Prim_DT     := DT (To_Tag_Ptr (This).all);
-      Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
-
-      --  Save Offset_Value in the table of interfaces of the primary DT.
-      --  This data will be used by the subprogram "Displace" to give support
-      --  to backward abstract interface type conversions.
-
-      --  Register the offset in the table of interfaces
-
-      if Iface_Table /= null then
-         for Id in 1 .. Iface_Table.Nb_Ifaces loop
-            if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
-               Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top :=
-                 Is_Static;
-
-               if Is_Static then
-                  Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value
-                    := Offset_Value;
-               else
-                  Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func
-                    := Offset_Func;
-               end if;
-
-               return;
-            end if;
-         end loop;
-      end if;
 
-      --  If we arrive here there is some error in the run-time data structure
-
-      raise Program_Error;
-   end Set_Offset_To_Top;
+      Register_Interface_Offset
+        (This, Interface_T, False, Offset_Value, Offset_Func);
+   end Set_Dynamic_Offset_To_Top;
 
    ----------------------
    -- Set_Prim_Op_Kind --

gcc/ada/a-tags.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -222,7 +222,8 @@ private
    --  type. This construct is used in the handling of dispatching triggers
    --  in select statements.
 
-   type Address_Array is array (Positive range <>) of System.Address;
+   type Prim_Ptr is access procedure;
+   type Address_Array is array (Positive range <>) of Prim_Ptr;
 
    subtype Dispatch_Table is Address_Array (1 .. 1);
    --  Used by GDB to identify the _tags and traverse the run-time structure
@@ -242,8 +243,14 @@ private
    type Tag_Ptr is access all Tag;
    pragma No_Strict_Aliasing (Tag_Ptr);
 
+   type Offset_To_Top_Ptr is access all SSE.Storage_Offset;
+   pragma No_Strict_Aliasing (Offset_To_Top_Ptr);
+
    type Tag_Table is array (Natural range <>) of Tag;
 
+   type Size_Ptr is
+     access function (A : System.Address) return Long_Long_Integer;
+
    type Type_Specific_Data (Idepth : Natural) is record
    --  The discriminant Idepth is the Inheritance Depth Level: Used to
    --  implement the membership test associated with single inheritance of
@@ -279,6 +286,12 @@ private
       --  Controller Offset: Used to give support to tagged controlled objects
       --  (see Get_Deep_Controller at s-finimp)
 
+      Size_Func : Size_Ptr;
+      --  Pointer to the subprogram computing the _size of the object. Used by
+      --  the run-time whenever a call to the 'size primitive is required. We
+      --  cannot assume that the contents of dispatch tables are addresses
+      --  because in some architectures the ABI allows descriptors.
+
       Interfaces_Table : Interface_Data_Ptr;
       --  Pointer to the table of interface tags. It is used to implement the
       --  membership test associated with interfaces and also for backward
@@ -370,6 +383,10 @@ private
 
    use type System.Storage_Elements.Storage_Offset;
 
+   DT_Offset_To_Top_Offset : constant SSE.Storage_Count :=
+                               DT_Typeinfo_Ptr_Size
+                                 + DT_Offset_To_Top_Size;
+
    DT_Predef_Prims_Offset : constant SSE.Storage_Count :=
                               DT_Typeinfo_Ptr_Size
                                 + DT_Offset_To_Top_Size
@@ -474,28 +491,44 @@ private
    pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
    --  This procedure is used in s-finimp and is thus exported manually
 
+   procedure Register_Interface_Offset
+     (This         : System.Address;
+      Interface_T  : Tag;
+      Is_Static    : Boolean;
+      Offset_Value : SSE.Storage_Offset;
+      Offset_Func  : Offset_To_Top_Function_Ptr);
+   --  Register in the table of interfaces of the tagged type associated with
+   --  "This" object the offset of the record component associated with the
+   --  progenitor Interface_T (that is, the distance from "This" to the object
+   --  component containing the tag of the secondary dispatch table). In case
+   --  of constant offset, Is_Static is true and Offset_Value has such value.
+   --  In case of variable offset, Is_Static is false and Offset_Func is an
+   --  access to function that must be called to evaluate the offset.
+
    procedure Register_Tag (T : Tag);
    --  Insert the Tag and its associated external_tag in a table for the
    --  sake of Internal_Tag
 
-   procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
-   --  Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
-   --  TSD table indexed by Position.
-
-   procedure Set_Offset_To_Top
+   procedure Set_Dynamic_Offset_To_Top
      (This         : System.Address;
       Interface_T  : Tag;
-      Is_Static    : Boolean;
       Offset_Value : SSE.Storage_Offset;
       Offset_Func  : Offset_To_Top_Function_Ptr);
-   --  Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of
-   --  the dispatch table. In primary dispatch tables the value of "This" is
-   --  not required (and the compiler passes always the Null_Address value) and
-   --  the Offset_Value is always cero; in secondary dispatch tables "This"
-   --  points to the object, Interface_T is the interface for which the
-   --  secondary dispatch table is being initialized, and Offset_Value is the
-   --  distance from "This" to the object component containing the tag of the
-   --  secondary dispatch table.
+   --  Ada 2005 (AI-251): The compiler generates calls to this routine only
+   --  when initializing the Offset_To_Top field of dispatch tables associated
+   --  with tagged type whose parent has variable size components. "This" is
+   --  the object whose dispatch table is being initialized. Interface_T is the
+   --  interface for which the secondary dispatch table is being initialized,
+   --  and Offset_Value is the distance from "This" to the object component
+   --  containing the tag of the secondary dispatch table (a zero value means
+   --  that this interface shares the primary dispatch table). Offset_Func
+   --  references a function that must be called to evaluate the offset at
+   --  runtime. This routine also takes care of registering these values in
+   --  the table of interfaces of the type.
+
+   procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
+   --  Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
+   --  TSD table indexed by Position.
 
    procedure Set_Prim_Op_Kind
      (T        : Tag;
@@ -532,5 +565,7 @@ private
 
    type Addr_Ptr is access System.Address;
    pragma No_Strict_Aliasing (Addr_Ptr);
-   --  Why is this needed ???
+   --  This type is used by the frontend to generate the code that handles
+   --  dispatch table slots of types declared at the local level.
+
 end Ada.Tags;

gcc/ada/checks.adb

@@ -450,6 +450,17 @@ package body Checks is
          return;
       end if;
 
+      --  No check if accessing the Offset_To_Top component of a dispatch
+      --  table. They are safe by construction.
+
+      if Present (Etype (P))
+        and then RTU_Loaded (Ada_Tags)
+        and then RTE_Available (RE_Offset_To_Top_Ptr)
+        and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
+      then
+         return;
+      end if;
+
       --  Otherwise go ahead and install the check
 
       Install_Null_Excluding_Check (P);
@@ -1239,12 +1250,23 @@ package body Checks is
                   return;
                end if;
 
-               exit when
-                 not Is_OK_Static_Expression (ItemS)
-                   or else
-                 not Is_OK_Static_Expression (ItemT);
+               --  If the expressions for the discriminants are identical
+               --  and it is side-effect free (for now just an entity),
+               --  this may be a shared constraint, e.g. from a subtype
+               --  without a constraint introduced as a generic actual.
+               --  Examine other discriminants if any.
+
+               if ItemS = ItemT
+                 and then Is_Entity_Name (ItemS)
+               then
+                  null;
+
+               elsif not Is_OK_Static_Expression (ItemS)
+                 or else not Is_OK_Static_Expression (ItemT)
+               then
+                  exit;
 
-               if Expr_Value (ItemS) /= Expr_Value (ItemT) then
+               elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then
                   if Do_Access then   --  needs run-time check.
                      exit;
                   else
@@ -2723,10 +2745,13 @@ package body Checks is
          end if;
       end if;
 
-      --  Check that null-excluding objects are always initialized
+      --  Check that null-excluding objects are always initialized, except for
+      --  deferred constants, for which the expression will appear in the full
+      --  declaration.
 
       if K = N_Object_Declaration
         and then No (Expression (N))
+        and then not Constant_Present (N)
         and then not No_Initialization (N)
       then
          --  Add an expression that assigns null. This node is needed by
@@ -2742,9 +2767,9 @@ package body Checks is
             Reason => CE_Null_Not_Allowed);
       end if;
 
-      --  Check that a null-excluding component, formal or object is not
-      --  being assigned a null value. Otherwise generate a warning message
-      --  and replace Expression (N) by a N_Constraint_Error node.
+      --  Check that a null-excluding component, formal or object is not being
+      --  assigned a null value. Otherwise generate a warning message and
+      --  replace Expression (N) by an N_Contraint_Error node.
 
       if K /= N_Function_Specification then
          Expr := Expression (N);
@@ -3368,14 +3393,14 @@ package body Checks is
       --  Nothing to do if the range of the result is known OK. We skip this
       --  for conversions, since the caller already did the check, and in any
       --  case the condition for deleting the check for a type conversion is
-      --  different in any case.
+      --  different.
 
       if Nkind (N) /= N_Type_Conversion then
          Determine_Range (N, OK, Lo, Hi);
 
-         --  Note in the test below that we assume that if a bound of the
-         --  range is equal to that of the type. That's not quite accurate
-         --  but we do this for the following reasons:
+         --  Note in the test below that we assume that the range is not OK
+         --  if a bound of the range is equal to that of the type. That's not
+         --  quite accurate but we do this for the following reasons:
 
          --   a) The way that Determine_Range works, it will typically report
          --      the bounds of the value as being equal to the bounds of the
@@ -3385,7 +3410,7 @@ package body Checks is
          --   b) It is very unusual to have a situation in which this would
          --      generate an unnecessary overflow check (an example would be
          --      a subtype with a range 0 .. Integer'Last - 1 to which the
-         --      literal value one is added.
+         --      literal value one is added).
 
          --   c) The alternative is a lot of special casing in this routine
          --      which would partially duplicate Determine_Range processing.
@@ -4121,12 +4146,7 @@ package body Checks is
       --  appropriate one for our purposes.
 
       if (Ekind (Ent) = E_Variable
-            or else
-          Ekind (Ent) = E_Constant
-            or else
-          Ekind (Ent) = E_Loop_Parameter
-            or else
-          Ekind (Ent) = E_In_Parameter)
+            or else Is_Constant_Object (Ent))
         and then not Is_Library_Level_Entity (Ent)
       then
          Entry_OK := True;
@@ -4371,7 +4391,8 @@ package body Checks is
                         Duplicate_Subexpr_Move_Checks (Sub)),
                     Right_Opnd =>
                       Make_Attribute_Reference (Loc,
-                        Prefix         => Duplicate_Subexpr_Move_Checks (A),
+                        Prefix         =>
+                          Duplicate_Subexpr_Move_Checks (A, Name_Req => True),
                         Attribute_Name => Name_Range,
                         Expressions    => Num)),
                 Reason => CE_Index_Check_Failed));

gcc/ada/checks.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -211,7 +211,7 @@ package Checks is
    --  by the back end, but many are done by the front end.
 
    --  Overflow checks are similarly controlled by the Do_Overflow_Check flag.
-   --  The difference here is that if Backend_Overflow_Checks is is
+   --  The difference here is that if back end overflow checks are inactive
    --  (Backend_Overflow_Checks_On_Target set False), then the actual overflow
    --  checks are generated by the front end, but if back end overflow checks
    --  are active (Backend_Overflow_Checks_On_Target set True), then the back

gcc/ada/exp_atag.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -26,9 +26,11 @@
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Exp_Util; use Exp_Util;
+with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Rtsfind;  use Rtsfind;
+with Sinfo;    use Sinfo;
 with Sem_Util; use Sem_Util;
 with Stand;    use Stand;
 with Snames;   use Snames;
@@ -57,15 +59,6 @@ package body Exp_Atag is
    --  Generate: To_Type_Specific_Data_Ptr
    --              (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
 
-   function Build_Predef_Prims
-     (Loc      : Source_Ptr;
-      Tag_Node : Node_Id) return Node_Id;
-   --  Build code that retrieves the address of the dispatch table containing
-   --  the predefined Ada primitives:
-   --
-   --  Generate: To_Predef_Prims_Table_Ptr
-   --              (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
-
    ------------------------------------------------
    -- Build_Common_Dispatching_Select_Statements --
    ------------------------------------------------
@@ -239,10 +232,33 @@ package body Exp_Atag is
       Position : Uint) return Node_Id
    is
    begin
+      --  Build code that retrieves the address of the dispatch table
+      --  containing the predefined Ada primitives:
+      --
+      --  Generate:
+      --    To_Predef_Prims_Table_Ptr
+      --     (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
+
       return
         Make_Indexed_Component (Loc,
           Prefix =>
-            Build_Predef_Prims (Loc, Tag_Node),
+            Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+              Make_Explicit_Dereference (Loc,
+                Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+                  Make_Function_Call (Loc,
+                    Name =>
+                      Make_Expanded_Name (Loc,
+                        Chars => Name_Op_Subtract,
+                        Prefix =>
+                          New_Reference_To
+                            (RTU_Entity (System_Storage_Elements), Loc),
+                        Selector_Name =>
+                          Make_Identifier (Loc,
+                            Chars => Name_Op_Subtract)),
+                    Parameter_Associations => New_List (
+                      Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
+                      New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
+                                        Loc)))))),
           Expressions =>
             New_List (Make_Integer_Literal (Loc, Position)));
    end Build_Get_Predefined_Prim_Op_Address;
@@ -397,35 +413,37 @@ package body Exp_Atag is
                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
    end Build_Inherit_Predefined_Prims;
 
-   ------------------------
-   -- Build_Predef_Prims --
-   ------------------------
+   -------------------------
+   -- Build_Offset_To_Top --
+   -------------------------
 
-   function Build_Predef_Prims
+   function Build_Offset_To_Top
      (Loc       : Source_Ptr;
-      Tag_Node : Node_Id) return Node_Id
+      This_Node : Node_Id) return Node_Id
    is
+      Tag_Node : Node_Id;
+
    begin
+      Tag_Node :=
+        Make_Explicit_Dereference (Loc,
+          Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
+
       return
-        Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
         Make_Explicit_Dereference (Loc,
-            Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+          Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
             Make_Function_Call (Loc,
               Name =>
                 Make_Expanded_Name (Loc,
                   Chars => Name_Op_Subtract,
-                    Prefix =>
-                      New_Reference_To
+                  Prefix => New_Reference_To
                              (RTU_Entity (System_Storage_Elements), Loc),
-                    Selector_Name =>
-                      Make_Identifier (Loc,
+                  Selector_Name => Make_Identifier (Loc,
                                      Chars => Name_Op_Subtract)),
-
               Parameter_Associations => New_List (
                 Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
-                  New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
-                                    Loc))))));
-   end Build_Predef_Prims;
+                New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
+                                  Loc)))));
+   end Build_Offset_To_Top;
 
    ------------------------------------------
    -- Build_Set_Predefined_Prim_Op_Address --
@@ -471,6 +489,60 @@ package body Exp_Atag is
           Expression => Address_Node);
    end Build_Set_Prim_Op_Address;
 
+   -----------------------------
+   -- Build_Set_Size_Function --
+   -----------------------------
+
+   function Build_Set_Size_Function
+     (Loc       : Source_Ptr;
+      Tag_Node  : Node_Id;
+      Size_Func : Entity_Id) return Node_Id is
+   begin
+      pragma Assert (Chars (Size_Func) = Name_uSize
+        and then RTE_Record_Component_Available (RE_Size_Func));
+      return
+        Make_Assignment_Statement (Loc,
+          Name =>
+            Make_Selected_Component (Loc,
+              Prefix => Build_TSD (Loc, Tag_Node),
+              Selector_Name =>
+                New_Reference_To
+                  (RTE_Record_Component (RE_Size_Func), Loc)),
+          Expression =>
+            Unchecked_Convert_To (RTE (RE_Size_Ptr),
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Reference_To (Size_Func, Loc),
+                Attribute_Name => Name_Unrestricted_Access)));
+   end Build_Set_Size_Function;
+
+   ------------------------------------
+   -- Build_Set_Static_Offset_To_Top --
+   ------------------------------------
+
+   function Build_Set_Static_Offset_To_Top
+     (Loc          : Source_Ptr;
+      Iface_Tag    : Node_Id;
+      Offset_Value : Node_Id) return Node_Id is
+   begin
+      return
+        Make_Assignment_Statement (Loc,
+          Make_Explicit_Dereference (Loc,
+            Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
+              Make_Function_Call (Loc,
+                Name =>
+                  Make_Expanded_Name (Loc,
+                    Chars => Name_Op_Subtract,
+                    Prefix => New_Reference_To
+                               (RTU_Entity (System_Storage_Elements), Loc),
+                    Selector_Name => Make_Identifier (Loc,
+                                       Chars => Name_Op_Subtract)),
+                Parameter_Associations => New_List (
+                  Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
+                  New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
+                                    Loc))))),
+          Offset_Value);
+   end Build_Set_Static_Offset_To_Top;
+
    ---------------
    -- Build_TSD --
    ---------------

gcc/ada/exp_atag.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -117,6 +117,19 @@ package Exp_Atag is
    --    New_Tag.Prims_Ptr (1 .. Num_Prims) :=
    --      Old_Tag.Prims_Ptr (1 .. Num_Prims);
 
+   function Build_Offset_To_Top
+     (Loc       : Source_Ptr;
+      This_Node : Node_Id) return Node_Id;
+   --  Build code that references the Offset_To_Top component of the primary
+   --  or secondary dispatch table associated with This_Node. This subprogram
+   --  provides a subset of the functionality provided by the function
+   --  Offset_To_Top of package Ada.Tags, and is only called by the frontend
+   --  when such routine is not available in a configurable runtime.
+   --
+   --  Generates:
+   --    Offset_To_Top_Ptr
+   --      (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset)
+
    function Build_Set_Predefined_Prim_Op_Address
      (Loc          : Source_Ptr;
       Tag_Node     : Node_Id;
@@ -145,4 +158,23 @@ package Exp_Atag is
    --
    --  Generates: Tag.D (Position) := Value
 
+   function Build_Set_Size_Function
+     (Loc       : Source_Ptr;
+      Tag_Node  : Node_Id;
+      Size_Func : Entity_Id) return Node_Id;
+   --  Build code that saves in the TSD the address of the function
+   --  calculating _size of the object.
+
+   function Build_Set_Static_Offset_To_Top
+     (Loc          : Source_Ptr;
+      Iface_Tag    : Node_Id;
+      Offset_Value : Node_Id) return Node_Id;
+   --  Build code that initialize the Offset_To_Top component of the
+   --  secondary dispatch table referenced by Iface_Tag.
+   --
+   --  Generates:
+   --    Offset_To_Top_Ptr
+   --      (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all
+   --     := Offset_Value
+
 end Exp_Atag;

gcc/ada/exp_ch13.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -145,11 +145,18 @@ package body Exp_Ch13 is
 
             --  For Storage_Size for an access type, create a variable to hold
             --  the value of the specified size with name typeV and expand an
-            --  assignment statement to initialze this value.
+            --  assignment statement to initialize this value.
 
             elsif Is_Access_Type (Ent) then
-               V := Make_Defining_Identifier (Loc,
-                      New_External_Name (Chars (Ent), 'V'));
+
+               --  We don't need the variable for a storage size of zero
+
+               if not No_Pool_Assigned (Ent) then
+                  V :=
+                    Make_Defining_Identifier (Loc,
+                      Chars => New_External_Name (Chars (Ent), 'V'));
+
+                  --  Insert the declaration of the object
 
                   Insert_Action (N,
                     Make_Object_Declaration (Loc,
@@ -161,6 +168,7 @@ package body Exp_Ch13 is
 
                   Set_Storage_Size_Variable (Ent, Entity_Id (V));
                end if;
+            end if;
 
          --  Other attributes require no expansion
 
@@ -207,6 +215,15 @@ package body Exp_Ch13 is
          return;
       end if;
 
+      --  Remember that we are processing a freezing entity and its freezing
+      --  nodes. This flag (non-zero = set) is used to avoid the need of
+      --  climbing through the tree while processing the freezing actions (ie.
+      --  to avoid generating spurious warnings or to avoid killing constant
+      --  indications while processing the code associated with freezing
+      --  actions). We use a counter to deal with nesting.
+
+      Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
+
       --  If we are freezing entities defined in protected types, they belong
       --  in the enclosing scope, given that the original type has been
       --  expanded away. The same is true for entities in task types, in
@@ -224,7 +241,6 @@ package body Exp_Ch13 is
 
       elsif Ekind (E_Scope) = E_Subprogram_Body then
          E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
-
       end if;
 
       S := Current_Scope;
@@ -339,6 +355,11 @@ package body Exp_Ch13 is
       elsif In_Outer_Scope then
          Pop_Scope;
       end if;
+
+      --  Restore previous value of the nesting-level counter that records
+      --  whether we are inside a (possibly nested) call to this procedure.
+
+      Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
    end Expand_N_Freeze_Entity;
 
    -------------------------------------------

gcc/ada/exp_ch3.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -570,7 +570,7 @@ package body Exp_Ch3 is
                 Name => Comp,
                 Expression =>
                   Get_Simple_Init_Val
-                    (Comp_Type, Loc, Component_Size (A_Type))));
+                    (Comp_Type, Nod, Component_Size (A_Type))));
 
          else
             Clean_Task_Names (Comp_Type, Proc_Id);
@@ -680,7 +680,18 @@ package body Exp_Ch3 is
                    and then Root_Type (A_Type) /= Standard_Wide_Wide_String)
       then
          Proc_Id :=
-           Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type));
+           Make_Defining_Identifier (Loc,
+             Chars => Make_Init_Proc_Name (A_Type));
+
+         --  If No_Default_Initialization restriction is active, then we don't
+         --  want to build an init_proc, but we need to mark that an init_proc
+         --  would be needed if this restriction was not active (so that we can
+         --  detect attempts to call it), so set a dummy init_proc in place.
+
+         if Restriction_Active (No_Default_Initialization) then
+            Set_Init_Proc (A_Type, Proc_Id);
+            return;
+         end if;
 
          Body_Stmts := Init_One_Dimension (1);
 
@@ -1018,15 +1029,17 @@ package body Exp_Ch3 is
       begin
          --  Build the discriminant checking function for each variant, label
          --  all components of that variant with the function's name.
+         --  We only Generate a discriminant-checking function only if the
+         --  variant is not empty, to prevent the creation of dead code.
 
          Discr_Name := Entity (Name (Variant_Part_Node));
          Variant := First_Non_Pragma (Variants (Variant_Part_Node));
 
          while Present (Variant) loop
-            Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
             Component_List_Node := Component_List (Variant);
 
             if not Null_Present (Component_List_Node) then
+               Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
                Decl :=
                  First_Non_Pragma (Component_Items (Component_List_Node));
 
@@ -2172,10 +2185,6 @@ package body Exp_Ch3 is
       begin
          Body_Stmts := New_List;
          Body_Node := New_Node (N_Subprogram_Body, Loc);
-
-         Proc_Id :=
-           Make_Defining_Identifier (Loc,
-             Chars => Make_Init_Proc_Name (Rec_Type));
          Set_Ekind (Proc_Id, E_Procedure);
 
          Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
@@ -2567,7 +2576,7 @@ package body Exp_Ch3 is
                elsif Component_Needs_Simple_Initialization (Typ) then
                   Stmts :=
                     Build_Assignment
-                      (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id)));
+                      (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)));
 
                --  Nothing needed for this case
 
@@ -2635,7 +2644,7 @@ package body Exp_Ch3 is
                   elsif Component_Needs_Simple_Initialization (Typ) then
                      Append_List_To (Statement_List,
                        Build_Assignment
-                         (Id, Get_Simple_Init_Val (Typ, Loc, Esize (Id))));
+                         (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))));
                   end if;
                end if;
 
@@ -3003,7 +3012,6 @@ package body Exp_Ch3 is
          end if;
 
          Id := First_Component (Rec_Id);
-
          while Present (Id) loop
             Comp_Decl := Parent (Id);
             Typ := Etype (Id);
@@ -3024,6 +3032,8 @@ package body Exp_Ch3 is
    --  Start of processing for Build_Record_Init_Proc
 
    begin
+      --  Check for value type, which means no initialization required
+
       Rec_Type := Defining_Identifier (N);
 
       if Is_Value_Type (Rec_Type) then
@@ -3080,6 +3090,20 @@ package body Exp_Ch3 is
       elsif Requires_Init_Proc (Rec_Type)
         or else Is_Unchecked_Union (Rec_Type)
       then
+         Proc_Id :=
+           Make_Defining_Identifier (Loc,
+             Chars => Make_Init_Proc_Name (Rec_Type));
+
+         --  If No_Default_Initialization restriction is active, then we don't
+         --  want to build an init_proc, but we need to mark that an init_proc
+         --  would be needed if this restriction was not active (so that we can
+         --  detect attempts to call it), so set a dummy init_proc in place.
+
+         if Restriction_Active (No_Default_Initialization) then
+            Set_Init_Proc (Rec_Type, Proc_Id);
+            return;
+         end if;
+
          Build_Offset_To_Top_Functions;
          Build_Init_Procedure;
          Set_Is_Public (Proc_Id, Is_Public (Pe));
@@ -3121,13 +3145,12 @@ package body Exp_Ch3 is
             procedure Collect_Itypes (Comp : Node_Id) is
                Ref      : Node_Id;
                Sub_Aggr : Node_Id;
-               Typ      : Entity_Id;
+               Typ      : constant Entity_Id := Etype (Comp);
 
             begin
-               if Is_Array_Type (Etype (Comp))
-                 and then Is_Itype (Etype (Comp))
+               if Is_Array_Type (Typ)
+                 and then Is_Itype (Typ)
                then
-                  Typ := Etype (Comp);
                   Ref := Make_Itype_Reference (Loc);
                   Set_Itype (Ref, Typ);
                   Append_Freeze_Action (Rec_Type, Ref);
@@ -3189,6 +3212,11 @@ package body Exp_Ch3 is
    --       Ri1 : Index;
 
    --    begin
+
+   --       if Left_Hi < Left_Lo then
+   --          return;
+   --       end if;
+
    --       if Rev  then
    --          Li1 := Left_Hi;
    --          Ri1 := Right_Hi;
@@ -3198,18 +3226,14 @@ package body Exp_Ch3 is
    --       end if;
 
    --       loop
-   --          if Rev then
-   --             exit when Li1 < Left_Lo;
-   --          else
-   --             exit when Li1 > Left_Hi;
-   --          end if;
-
    --          Target (Li1) := Source (Ri1);
 
    --          if Rev then
+   --             exit when Li1 = Left_Lo;
    --             Li1 := Index'pred (Li1);
    --             Ri1 := Index'pred (Ri1);
    --          else
+   --             exit when Li1 = Left_Hi;
    --             Li1 := Index'succ (Li1);
    --             Ri1 := Index'succ (Ri1);
    --          end if;
@@ -3276,6 +3300,16 @@ package body Exp_Ch3 is
 
       Stats := New_List;
 
+      --  Build test for empty slice case
+
+      Append_To (Stats,
+        Make_If_Statement (Loc,
+          Condition =>
+             Make_Op_Lt (Loc,
+               Left_Opnd  => New_Occurrence_Of (Left_Hi, Loc),
+               Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)),
+          Then_Statements => New_List (Make_Simple_Return_Statement (Loc))));
+
       --  Build initializations for indices
 
       declare
@@ -3326,7 +3360,7 @@ package body Exp_Ch3 is
                   Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))),
           End_Label  => Empty);
 
-      --  Build exit condition
+      --  Build the exit condition and increment/decrement statements
 
       declare
          F_Ass : constant List_Id := New_List;
@@ -3336,31 +3370,10 @@ package body Exp_Ch3 is
          Append_To (F_Ass,
            Make_Exit_Statement (Loc,
              Condition =>
-               Make_Op_Gt (Loc,
+               Make_Op_Eq (Loc,
                  Left_Opnd  => New_Occurrence_Of (Lnn, Loc),
                  Right_Opnd => New_Occurrence_Of (Left_Hi, Loc))));
 
-         Append_To (B_Ass,
-           Make_Exit_Statement (Loc,
-             Condition =>
-               Make_Op_Lt (Loc,
-                 Left_Opnd  => New_Occurrence_Of (Lnn, Loc),
-                 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
-
-         Prepend_To (Statements (Loops),
-           Make_If_Statement (Loc,
-             Condition       => New_Occurrence_Of (Rev, Loc),
-             Then_Statements => B_Ass,
-             Else_Statements => F_Ass));
-      end;
-
-      --  Build the increment/decrement statements
-
-      declare
-         F_Ass : constant List_Id := New_List;
-         B_Ass : constant List_Id := New_List;
-
-      begin
          Append_To (F_Ass,
            Make_Assignment_Statement (Loc,
              Name => New_Occurrence_Of (Lnn, Loc),
@@ -3384,6 +3397,13 @@ package body Exp_Ch3 is
                    New_Occurrence_Of (Rnn, Loc)))));
 
          Append_To (B_Ass,
+           Make_Exit_Statement (Loc,
+             Condition =>
+               Make_Op_Eq (Loc,
+                 Left_Opnd  => New_Occurrence_Of (Lnn, Loc),
+                 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc))));
+
+         Append_To (B_Ass,
            Make_Assignment_Statement (Loc,
              Name => New_Occurrence_Of (Lnn, Loc),
              Expression =>
@@ -4220,6 +4240,12 @@ package body Exp_Ch3 is
 
             and then not Suppress_Init_Proc (Typ)
          then
+            Check_Restriction (No_Default_Initialization, N);
+
+            if Restriction_Active (No_Default_Initialization) then
+               return;
+            end if;
+
             --  The call to the initialization procedure does NOT freeze the
             --  object being initialized. This is because the call is not a
             --  source level call. This works fine, because the only possible
@@ -4260,8 +4286,9 @@ package body Exp_Ch3 is
            and then not Is_Internal (Def_Id)
            and then not Has_Init_Expression (N)
          then
+            Check_Restriction (No_Default_Initialization, N);
             Set_No_Initialization (N, False);
-            Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id)));
+            Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
             Analyze_And_Resolve (Expression (N), Typ);
          end if;
 
@@ -5437,10 +5464,18 @@ package body Exp_Ch3 is
 
             Set_Is_Frozen (Def_Id, False);
 
+            --  Do not add the spec of predefined primitives in case of
+            --  CPP tagged type derivations that have convention CPP.
+
+            if Is_CPP_Class (Root_Type (Def_Id))
+              and then Convention (Def_Id) = Convention_CPP
+            then
+               null;
+
             --  Do not add the spec of the predefined primitives if we are
             --  compiling under restriction No_Dispatching_Calls
 
-            if not Restriction_Active (No_Dispatching_Calls) then
+            elsif not Restriction_Active (No_Dispatching_Calls) then
                Make_Predefined_Primitive_Specs
                  (Def_Id, Predef_List, Renamed_Eq);
                Insert_List_Before_And_Analyze (N, Predef_List);
@@ -5614,11 +5649,19 @@ package body Exp_Ch3 is
       if Is_Tagged_Type (Def_Id)
         and then not Is_Interface (Def_Id)
       then
+         --  Do not add the body of predefined primitives in case of
+         --  CPP tagged type derivations that have convention CPP.
+
+         if Is_CPP_Class (Root_Type (Def_Id))
+           and then Convention (Def_Id) = Convention_CPP
+         then
+            null;
 
          --  Do not add the body of the predefined primitives if we are
-         --  compiling under restriction No_Dispatching_Calls
+         --  compiling under restriction No_Dispatching_Calls of if we
+         --  are compiling a CPP tagged type.
 
-         if not Restriction_Active (No_Dispatching_Calls) then
+         elsif not Restriction_Active (No_Dispatching_Calls) then
             Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
             Append_Freeze_Actions (Def_Id, Predef_List);
          end if;
@@ -5816,26 +5859,16 @@ package body Exp_Ch3 is
             Loc         : constant Source_Ptr := Sloc (N);
             Desig_Type  : constant Entity_Id  := Designated_Type (Def_Id);
             Pool_Object : Entity_Id;
-            Siz_Exp     : Node_Id;
 
             Freeze_Action_Typ : Entity_Id;
 
          begin
-            if Has_Storage_Size_Clause (Def_Id) then
-               Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id)));
-            else
-               Siz_Exp := Empty;
-            end if;
-
             --  Case 1
 
             --    Rep Clause "for Def_Id'Storage_Size use 0;"
             --    ---> don't use any storage pool
 
-            if Has_Storage_Size_Clause (Def_Id)
-              and then Compile_Time_Known_Value (Siz_Exp)
-              and then Expr_Value (Siz_Exp) = 0
-            then
+            if No_Pool_Assigned (Def_Id) then
                null;
 
             --  Case 2
@@ -6046,9 +6079,10 @@ package body Exp_Ch3 is
 
    function Get_Simple_Init_Val
      (T    : Entity_Id;
-      Loc  : Source_Ptr;
+      N    : Node_Id;
       Size : Uint := No_Uint) return Node_Id
    is
+      Loc    : constant Source_Ptr := Sloc (N);
       Val    : Node_Id;
       Result : Node_Id;
       Val_RE : RE_Id;
@@ -6057,6 +6091,10 @@ package body Exp_Ch3 is
       --  This is the size to be used for computation of the appropriate
       --  initial value for the Normalize_Scalars and Initialize_Scalars case.
 
+      IV_Attribute : constant Boolean :=
+                       Nkind (N) = N_Attribute_Reference
+                         and then Attribute_Name (N) = Name_Invalid_Value;
+
       Lo_Bound : Uint;
       Hi_Bound : Uint;
       --  These are the values computed by the procedure Check_Subtype_Bounds
@@ -6133,7 +6171,7 @@ package body Exp_Ch3 is
       --  an Unchecked_Convert to the private type.
 
       if Is_Private_Type (T) then
-         Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size);
+         Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
 
          --  A special case, if the underlying value is null, then qualify it
          --  with the underlying type, so that the null is properly typed
@@ -6160,10 +6198,11 @@ package body Exp_Ch3 is
 
          return Result;
 
-      --  For scalars, we must have normalize/initialize scalars case
+      --  For scalars, we must have normalize/initialize scalars case, or
+      --  if the node N is an 'Invalid_Value attribute node.
 
       elsif Is_Scalar_Type (T) then
-         pragma Assert (Init_Or_Norm_Scalars);
+         pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
 
          --  Compute size of object. If it is given by the caller, we can use
          --  it directly, otherwise we use Esize (T) as an estimate. As far as
@@ -6188,7 +6227,7 @@ package body Exp_Ch3 is
 
          --  Processing for Normalize_Scalars case
 
-         if Normalize_Scalars then
+         if Normalize_Scalars and then not IV_Attribute then
 
             --  If zero is invalid, it is a convenient value to use that is
             --  for sure an appropriate invalid value in all situations.
@@ -6252,7 +6291,7 @@ package body Exp_Ch3 is
                end;
             end if;
 
-         --  Here for Initialize_Scalars case
+         --  Here for Initialize_Scalars case (or Invalid_Value attribute used)
 
          else
             --  For float types, use float values from System.Scalar_Values
@@ -6347,7 +6386,7 @@ package body Exp_Ch3 is
                    Make_Others_Choice (Loc)),
                  Expression =>
                    Get_Simple_Init_Val
-                     (Component_Type (T), Loc, Esize (Root_Type (T))))));
+                     (Component_Type (T), N, Esize (Root_Type (T))))));
 
       --  Access type is initialized to null
 
@@ -6615,14 +6654,6 @@ package body Exp_Ch3 is
                   New_Reference_To (Iface_Tag, Loc)));
          end if;
 
-         --  Issue error if Set_Offset_To_Top is not available in a
-         --  configurable run-time environment.
-
-         if not RTE_Available (RE_Set_Offset_To_Top) then
-            Error_Msg_CRT ("abstract interface types", Typ);
-            return;
-         end if;
-
          Comp_Typ := Scope (Tag_Comp);
 
          --  Initialize the entries of the table of interfaces. We generate a
@@ -6636,17 +6667,26 @@ package body Exp_Ch3 is
             pragma Assert
               (Present (DT_Offset_To_Top_Func (Tag_Comp)));
 
+            --  Issue error if Set_Dynamic_Offset_To_Top is not available in a
+            --  configurable run-time environment.
+
+            if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then
+               Error_Msg_CRT
+                 ("variable size record with interface types", Typ);
+               return;
+            end if;
+
             --  Generate:
-            --    Set_Offset_To_Top
+            --    Set_Dynamic_Offset_To_Top
             --      (This         => Init,
             --       Interface_T  => Iface'Tag,
-            --       Is_Constant  => False,
             --       Offset_Value => n,
             --       Offset_Func  => Fn'Address)
 
             Append_To (Stmts_List,
               Make_Procedure_Call_Statement (Loc,
-                Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
+                Name => New_Reference_To
+                          (RTE (RE_Set_Dynamic_Offset_To_Top), Loc),
                 Parameter_Associations => New_List (
                   Make_Attribute_Reference (Loc,
                     Prefix => New_Copy_Tree (Target),
@@ -6657,8 +6697,6 @@ package body Exp_Ch3 is
                       (Node (First_Elmt (Access_Disp_Table (Iface))),
                        Loc)),
 
-                  New_Occurrence_Of (Standard_False, Loc),
-
                   Unchecked_Convert_To
                     (RTE (RE_Storage_Offset),
                      Make_Attribute_Reference (Loc,
@@ -6700,18 +6738,38 @@ package body Exp_Ch3 is
          --  Normal case: No discriminants in the parent type
 
          else
+            --  Don't need to set any value if this interface shares
+            --  the primary dispatch table
+
+            if not Is_Parent (Iface, Typ) then
+               Append_To (Stmts_List,
+                 Build_Set_Static_Offset_To_Top (Loc,
+                   Iface_Tag =>
+                     New_Reference_To (Iface_Tag, Loc),
+                   Offset_Value =>
+                     Unchecked_Convert_To (RTE (RE_Storage_Offset),
+                       Make_Attribute_Reference (Loc,
+                         Prefix =>
+                           Make_Selected_Component (Loc,
+                             Prefix => New_Copy_Tree (Target),
+                             Selector_Name  =>
+                               New_Reference_To (Tag_Comp, Loc)),
+                         Attribute_Name => Name_Position))));
+            end if;
+
             --  Generate:
-            --    Set_Offset_To_Top
+            --    Register_Interface_Offset
             --      (This         => Init,
             --       Interface_T  => Iface'Tag,
             --       Is_Constant  => True,
             --       Offset_Value => n,
             --       Offset_Func  => null);
 
+            if RTE_Available (RE_Register_Interface_Offset) then
                Append_To (Stmts_List,
                  Make_Procedure_Call_Statement (Loc,
                    Name => New_Reference_To
-                          (RTE (RE_Set_Offset_To_Top), Loc),
+                             (RTE (RE_Register_Interface_Offset), Loc),
                    Parameter_Associations => New_List (
                      Make_Attribute_Reference (Loc,
                        Prefix => New_Copy_Tree (Target),
@@ -6737,6 +6795,7 @@ package body Exp_Ch3 is
 
                      Make_Null (Loc))));
             end if;
+         end if;
       end Initialize_Tag;
 
       --  Local variables
@@ -6816,6 +6875,32 @@ package body Exp_Ch3 is
       Comp_Typ : Entity_Id;
       Idx      : Node_Id;
 
+      function Is_Constant_Bound (Exp : Node_Id) return Boolean;
+      --  To simplify handling of array components. Determines whether the
+      --  given bound is constant (a constant or enumeration literal, or an
+      --  integer literal) as opposed to per-object, through an expression
+      --  or a discriminant.
+
+      -----------------------
+      -- Is_Constant_Bound --
+      -----------------------
+
+      function Is_Constant_Bound (Exp : Node_Id) return Boolean is
+      begin
+         if Nkind (Exp) = N_Integer_Literal then
+            return True;
+         else
+            return
+              Is_Entity_Name (Exp)
+                and then Present (Entity (Exp))
+                and then
+                 (Ekind (Entity (Exp)) = E_Constant
+                   or else Ekind (Entity (Exp)) = E_Enumeration_Literal);
+         end if;
+      end Is_Constant_Bound;
+
+   --  Start of processing for Is_Variable_Sized_Record
+
    begin
       pragma Assert (Is_Record_Type (E));
 
@@ -6840,15 +6925,9 @@ package body Exp_Ch3 is
             Idx := First_Index (Comp_Typ);
             while Present (Idx) loop
                if Nkind (Idx) = N_Range then
-                  if (Nkind (Low_Bound (Idx)) = N_Identifier
-                       and then Present (Entity (Low_Bound (Idx)))
-                       and then
-                         Ekind (Entity (Low_Bound (Idx))) /= E_Constant)
+                  if not Is_Constant_Bound (Low_Bound  (Idx))
                        or else
-                     (Nkind (High_Bound (Idx)) = N_Identifier
-                       and then Present (Entity (High_Bound (Idx)))
-                       and then
-                         Ekind (Entity (High_Bound (Idx))) /= E_Constant)
+                     not Is_Constant_Bound (High_Bound (Idx))
                   then
                      return True;
                   end if;
@@ -7506,6 +7585,7 @@ package body Exp_Ch3 is
 
       if Ada_Version >= Ada_05
         and then VM_Target = No_VM
+        and then RTE_Available (RE_Select_Specific_Data)
       then
          --  These primitives are defined abstract in interface types
 
@@ -7608,8 +7688,14 @@ package body Exp_Ch3 is
          --  initialization of its dispatch table.
 
         or else (not Is_Interface (Tag_Typ)
-                   and then
-                 Is_Interface (Etype (Tag_Typ)))
+                   and then Is_Interface (Etype (Tag_Typ)))
+
+         --  Ada 205 (AI-251): We must also generate these subprograms if
+         --  the parent of an nonlimited interface is a limited interface
+
+        or else (Is_Interface (Tag_Typ)
+                  and then not Is_Limited_Interface (Tag_Typ)
+                  and then Is_Limited_Interface (Etype (Tag_Typ)))
       then
          if not Is_Limited_Type (Tag_Typ) then
             Append_To (Res,
@@ -7999,6 +8085,7 @@ package body Exp_Ch3 is
               and then Is_Limited_Record (Etype (Tag_Typ)))
            or else (Is_Concurrent_Record_Type (Tag_Typ)
                      and then Has_Abstract_Interfaces (Tag_Typ)))
+        and then RTE_Available (RE_Select_Specific_Data)
       then
          Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
          Append_To (Res, Make_Disp_Conditional_Select_Body  (Tag_Typ));

gcc/ada/exp_ch3.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -133,16 +133,18 @@ package Exp_Ch3 is
 
    function Get_Simple_Init_Val
      (T    : Entity_Id;
-      Loc  : Source_Ptr;
+      N    : Node_Id;
       Size : Uint := No_Uint) return Node_Id;
    --  For a type which Needs_Simple_Initialization (see above), prepares the
-   --  tree for an expression representing the required initial value. Loc is
-   --  the source location used in constructing this tree which is returned as
-   --  the result of the call. The Size parameter indicates the target size of
-   --  the object if it is known (indicated by a value that is not No_Uint and
-   --  is greater than zero). If Size is not given (Size set to No_Uint, or
-   --  non-positive), then the Esize of T is used as an estimate of the Size.
-   --  The object size is needed to prepare a known invalid value for use by
-   --  Normalize_Scalars.
+   --  tree for an expression representing the required initial value. N is a
+   --  node whose source location used in constructing this tree which is
+   --  returned as the result of the call. The Size parameter indicates the
+   --  target size of the object if it is known (indicated by a value that is
+   --  not No_Uint and is greater than zero). If Size is not given (Size set to
+   --  No_Uint, or non-positive), then the Esize of T is used as an estimate of
+   --  the Size. The object size is needed to prepare a known invalid value for
+   --  use by Normalize_Scalars. A call to this routine where T is a scalar
+   --  type is only valid if we are in Normalize_Scalars or Initialize_Scalars
+   --  mode, or if N is the node for a 'Invalid_Value attribute node.
 
 end Exp_Ch3;

gcc/ada/exp_disp.adb

@@ -99,7 +99,15 @@ package body Exp_Disp is
    ------------------------
 
    function Building_Static_DT (Typ : Entity_Id) return Boolean is
+      Root_Typ : Entity_Id := Root_Type (Typ);
+
    begin
+      --  Handle private types
+
+      if Present (Full_View (Root_Typ)) then
+         Root_Typ := Full_View (Root_Typ);
+      end if;
+
       return Static_Dispatch_Tables
         and then Is_Library_Level_Tagged_Type (Typ)
 
@@ -107,7 +115,7 @@ package body Exp_Disp is
          --  build the dispatch tables because we must inherit primitives
          --  from the CPP side.
 
-        and then not Is_CPP_Class (Root_Type (Typ));
+        and then not Is_CPP_Class (Root_Typ);
    end Building_Static_DT;
 
    ----------------------------------
@@ -548,7 +556,6 @@ package body Exp_Disp is
       Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
       Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
       Set_Etype          (Subp_Typ, Res_Typ);
-      Init_Size_Align    (Subp_Ptr_Typ);
       Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
 
       --  Create a new list of parameters which is a copy of the old formal
@@ -575,18 +582,11 @@ package body Exp_Disp is
                   Set_Etype (New_Formal, Etype (Param));
                end if;
 
-               if Is_Itype (Etype (New_Formal)) then
-                  Extra := New_Copy (Etype (New_Formal));
-
-                  if Ekind (Extra) = E_Record_Subtype
-                    or else Ekind (Extra) = E_Class_Wide_Subtype
-                  then
-                     Set_Cloned_Subtype (Extra, Etype (New_Formal));
-                  end if;
-
-                  Set_Etype (New_Formal, Extra);
-                  Set_Scope (Etype (New_Formal), Subp_Typ);
-               end if;
+               --  If the type of the formal is an itype, there was code here
+               --  introduced in 1998 in revision 1.46, to create a new itype
+               --  by copy. This seems useless, and in fact leads to semantic
+               --  errors when the itype is the completion of a type derived
+               --  from a private type.
 
                Extra := New_Formal;
                Next_Formal (Old_Formal);
@@ -780,7 +780,7 @@ package body Exp_Disp is
          --  Give error if configurable run time and Displace not available
 
          if not RTE_Available (RE_Displace) then
-            Error_Msg_CRT ("abstract interface types", N);
+            Error_Msg_CRT ("dynamic interface conversion", N);
             return;
          end if;
 
@@ -840,8 +840,6 @@ package body Exp_Disp is
          begin
             New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
             Set_Etype (New_Itype, New_Itype);
-            Init_Esize      (New_Itype);
-            Init_Size_Align (New_Itype);
             Set_Directly_Designated_Type (New_Itype, Etyp);
 
             Rewrite (N,
@@ -1205,6 +1203,8 @@ package body Exp_Disp is
       Decl_1          : Node_Id;
       Decl_2          : Node_Id;
       Formal          : Node_Id;
+      New_Arg         : Node_Id;
+      Offset_To_Top   : Node_Id;
       Target          : Entity_Id;
       Target_Formal   : Entity_Id;
 
@@ -1212,13 +1212,6 @@ package body Exp_Disp is
       Thunk_Id   := Empty;
       Thunk_Code := Empty;
 
-      --  Give message if configurable run-time and Offset_To_Top unavailable
-
-      if not RTE_Available (RE_Offset_To_Top) then
-         Error_Msg_CRT ("abstract interface types", Prim);
-         return;
-      end if;
-
       --  Traverse the list of alias to find the final target
 
       Target := Prim;
@@ -1284,6 +1277,20 @@ package body Exp_Disp is
                         (Directly_Designated_Type
                           (Etype (Target_Formal)), Loc)));
 
+            New_Arg :=
+              Unchecked_Convert_To (RTE (RE_Address),
+                New_Reference_To (Defining_Identifier (Formal), Loc));
+
+            if not RTE_Available (RE_Offset_To_Top) then
+               Offset_To_Top :=
+                 Build_Offset_To_Top (Loc, New_Arg);
+            else
+               Offset_To_Top :=
+                 Make_Function_Call (Loc,
+                   Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
+                   Parameter_Associations => New_List (New_Arg));
+            end if;
+
             Decl_1 :=
               Make_Object_Declaration (Loc,
                 Defining_Identifier =>
@@ -1299,14 +1306,7 @@ package body Exp_Disp is
                         (RTE (RE_Storage_Offset),
                          New_Reference_To (Defining_Identifier (Formal), Loc)),
                      Right_Opnd =>
-                       Make_Function_Call (Loc,
-                         Name =>
-                           New_Reference_To (RTE (RE_Offset_To_Top), Loc),
-                         Parameter_Associations => New_List (
-                           Unchecked_Convert_To
-                             (RTE (RE_Address),
-                              New_Reference_To
-                                (Defining_Identifier (Formal), Loc))))));
+                       Offset_To_Top));
 
             Append_To (Decl, Decl_2);
             Append_To (Decl, Decl_1);
@@ -1326,6 +1326,23 @@ package body Exp_Disp is
             --                             - Offset_To_Top (Formal'Address)
             --     S2 : Addr_Ptr := Addr_Ptr!(S1)
 
+            New_Arg :=
+              Make_Attribute_Reference (Loc,
+                Prefix =>
+                  New_Reference_To (Defining_Identifier (Formal), Loc),
+                Attribute_Name =>
+                  Name_Address);
+
+            if not RTE_Available (RE_Offset_To_Top) then
+               Offset_To_Top :=
+                 Build_Offset_To_Top (Loc, New_Arg);
+            else
+               Offset_To_Top :=
+                 Make_Function_Call (Loc,
+                   Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
+                   Parameter_Associations => New_List (New_Arg));
+            end if;
+
             Decl_1 :=
               Make_Object_Declaration (Loc,
                 Defining_Identifier =>
@@ -1344,15 +1361,7 @@ package body Exp_Disp is
                                (Defining_Identifier (Formal), Loc),
                            Attribute_Name => Name_Address)),
                     Right_Opnd =>
-                       Make_Function_Call (Loc,
-                         Name =>
-                           New_Reference_To (RTE (RE_Offset_To_Top), Loc),
-                         Parameter_Associations => New_List (
-                           Make_Attribute_Reference (Loc,
-                             Prefix =>
-                               New_Reference_To
-                                 (Defining_Identifier (Formal), Loc),
-                             Attribute_Name => Name_Address)))));
+                      Offset_To_Top));
 
             Decl_2 :=
               Make_Object_Declaration (Loc,
@@ -3042,6 +3051,10 @@ package body Exp_Disp is
                                (Expression
                                  (Parent (RTE (RE_Max_Predef_Prims)))));
 
+      DT_Decl : constant Elist_Id := New_Elmt_List;
+      DT_Aggr : constant Elist_Id := New_Elmt_List;
+      --  Entities marked with attribute Is_Dispatch_Table_Entity
+
       procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id);
       --  Verify that all non-tagged types in the profile of a subprogram
       --  are frozen at the point the subprogram is frozen. This enforces
@@ -3229,6 +3242,7 @@ package body Exp_Disp is
 
          declare
             Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
+            Decl       : Node_Id;
             Thunk_Id   : Entity_Id;
             Thunk_Code : Node_Id;
 
@@ -3272,27 +3286,43 @@ package body Exp_Disp is
             for J in Prim_Table'Range loop
                if Present (Prim_Table (J)) then
                   New_Node :=
-                    Unchecked_Convert_To (RTE (RE_Address),
+                    Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                       Make_Attribute_Reference (Loc,
                         Prefix => New_Reference_To (Prim_Table (J), Loc),
                         Attribute_Name => Name_Unrestricted_Access));
                else
-                  New_Node :=
-                    New_Reference_To (RTE (RE_Null_Address), Loc);
+                  New_Node := Make_Null (Loc);
                end if;
 
                Append_To (Prim_Ops_Aggr_List, New_Node);
             end loop;
 
+            New_Node :=
+              Make_Aggregate (Loc,
+                Expressions => Prim_Ops_Aggr_List);
+
+            --  Remember aggregates initializing dispatch tables
+
+            Append_Elmt (New_Node, DT_Aggr);
+
+            Decl :=
+              Make_Subtype_Declaration (Loc,
+                Defining_Identifier =>
+                  Make_Defining_Identifier (Loc,
+                    New_Internal_Name ('S')),
+                Subtype_Indication =>
+                  New_Reference_To (RTE (RE_Address_Array), Loc));
+
+            Append_To (Result, Decl);
+
             Append_To (Result,
               Make_Object_Declaration (Loc,
                 Defining_Identifier => Predef_Prims,
                 Constant_Present    => Building_Static_DT (Typ),
                 Aliased_Present     => True,
-                Object_Definition   =>
-                  New_Reference_To (RTE (RE_Address_Array), Loc),
-                Expression => Make_Aggregate (Loc,
-                  Expressions => Prim_Ops_Aggr_List)));
+                Object_Definition   => New_Reference_To
+                                         (Defining_Identifier (Decl), Loc),
+                Expression => New_Node));
 
             Append_To (Result,
               Make_Attribute_Definition_Clause (Loc,
@@ -3492,15 +3522,13 @@ package body Exp_Disp is
          Prim_Ops_Aggr_List := New_List;
 
          if Empty_DT then
-            Append_To (Prim_Ops_Aggr_List,
-              New_Reference_To (RTE (RE_Null_Address), Loc));
+            Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
 
          elsif Is_Abstract_Type (Typ)
            or else not Building_Static_DT (Typ)
          then
             for J in 1 .. Nb_Prim loop
-               Append_To (Prim_Ops_Aggr_List,
-                 New_Reference_To (RTE (RE_Null_Address), Loc));
+               Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
             end loop;
 
          else
@@ -3556,13 +3584,12 @@ package body Exp_Disp is
                for J in Prim_Table'Range loop
                   if Present (Prim_Table (J)) then
                      New_Node :=
-                       Unchecked_Convert_To (RTE (RE_Address),
+                       Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                          Make_Attribute_Reference (Loc,
                            Prefix => New_Reference_To (Prim_Table (J), Loc),
                            Attribute_Name => Name_Unrestricted_Access));
                   else
-                     New_Node :=
-                       New_Reference_To (RTE (RE_Null_Address), Loc);
+                     New_Node := Make_Null (Loc);
                   end if;
 
                   Append_To (Prim_Ops_Aggr_List, New_Node);
@@ -3570,9 +3597,15 @@ package body Exp_Disp is
             end;
          end if;
 
-         Append_To (DT_Aggr_List,
+         New_Node :=
            Make_Aggregate (Loc,
-             Expressions => Prim_Ops_Aggr_List));
+             Expressions => Prim_Ops_Aggr_List);
+
+         Append_To (DT_Aggr_List, New_Node);
+
+         --  Remember aggregates initializing dispatch tables
+
+         Append_Elmt (New_Node, DT_Aggr);
 
          Append_To (Result,
            Make_Object_Declaration (Loc,
@@ -3635,14 +3668,10 @@ package body Exp_Disp is
                        (RTE_Record_Component (RE_Predef_Prims), Loc)),
                  Attribute_Name => Name_Address)));
 
-         --  Mark entities containing library level static dispatch tables.
-         --  This attribute is later propagated to all the access-to-subprogram
-         --  itypes generated to fill the dispatch table slots (see exp_attr).
+         --  Remember entities containing dispatch tables
 
-         if Building_Static_DT (Typ) then
-            Set_Is_Static_Dispatch_Table_Entity (Predef_Prims);
-            Set_Is_Static_Dispatch_Table_Entity (Iface_DT);
-         end if;
+         Append_Elmt (Predef_Prims, DT_Decl);
+         Append_Elmt (Iface_DT, DT_Decl);
       end Make_Secondary_DT;
 
       --  Local variables
@@ -3666,6 +3695,7 @@ package body Exp_Disp is
       New_Node           : Node_Id;
       No_Reg             : Node_Id;
       Num_Ifaces         : Nat := 0;
+      Parent_Typ         : Entity_Id;
       Prim               : Entity_Id;
       Prim_Elmt          : Elmt_Id;
       Prim_Ops_Aggr_List : List_Id;
@@ -3761,6 +3791,14 @@ package body Exp_Disp is
          end if;
       end if;
 
+      --  Initialize Parent_Typ handling private types
+
+      Parent_Typ := Etype (Typ);
+
+      if Present (Full_View (Parent_Typ)) then
+         Parent_Typ := Full_View (Parent_Typ);
+      end if;
+
       --  Ensure that all the primitives are frozen. This is only required when
       --  building static dispatch tables --- the primitives must be frozen to
       --  be referenced (otherwise we have problems with the backend). It is
@@ -4045,6 +4083,7 @@ package body Exp_Disp is
       --            HT_Link            => HT_Link'Address,
       --            Transportable      => <<boolean-value>>,
       --            RC_Offset          => <<integer-value>>,
+      --            [ Size_Func         => Size_Prim'Access ]
       --            [ Interfaces_Table  => <<access-value>> ]
       --            [ SSD               => SSD_Table'Address ]
       --            Tags_Table         => (0 => null,
@@ -4204,18 +4243,23 @@ package body Exp_Disp is
       --  External tag of a library-level tagged type: Check for a definition
       --  of External_Tag. The clause is considered only if it applies to this
       --  specific tagged type, as opposed to one of its ancestors.
+      --  If the type is an unconstrained type extension, we are building the
+      --  dispatch table of its anonymous base type, so the external tag, if
+      --  any was specified, must be retrieved from the first subtype.
 
       else
          declare
-            Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ,
+            Def : constant Node_Id := Get_Attribute_Definition_Clause
+                                        (First_Subtype (Typ),
                                          Attribute_External_Tag);
+
             Old_Val : String_Id;
             New_Val : String_Id;
             E       : Entity_Id;
 
          begin
             if not Present (Def)
-              or else Entity (Name (Def)) /= Typ
+              or else Entity (Name (Def)) /= First_Subtype (Typ)
             then
                New_Node :=
                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
@@ -4320,15 +4364,8 @@ package body Exp_Disp is
 
       declare
          RC_Offset_Node : Node_Id;
-         Parent_Typ     : Entity_Id;
 
       begin
-         if Present (Full_View (Etype (Typ))) then
-            Parent_Typ := Full_View (Etype (Typ));
-         else
-            Parent_Typ := Etype (Typ);
-         end if;
-
          if not Has_Controlled_Component (Typ) then
             RC_Offset_Node := Make_Integer_Literal (Loc, 0);
 
@@ -4368,6 +4405,52 @@ package body Exp_Disp is
          Append_To (TSD_Aggr_List, RC_Offset_Node);
       end;
 
+      --  Size_Func
+
+      if RTE_Record_Component_Available (RE_Size_Func) then
+         if not Building_Static_DT (Typ)
+           or else Is_Interface (Typ)
+         then
+            Append_To (TSD_Aggr_List,
+              Unchecked_Convert_To (RTE (RE_Size_Ptr),
+                New_Reference_To (RTE (RE_Null_Address), Loc)));
+
+         else
+            declare
+               Prim_Elmt : Elmt_Id;
+               Prim      : Entity_Id;
+
+            begin
+               Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+               while Present (Prim_Elmt) loop
+                  Prim := Node (Prim_Elmt);
+
+                  if Chars (Prim) = Name_uSize then
+                     while Present (Alias (Prim)) loop
+                        Prim := Alias (Prim);
+                     end loop;
+
+                     if Is_Abstract_Subprogram (Prim) then
+                        Append_To (TSD_Aggr_List,
+                          Unchecked_Convert_To (RTE (RE_Size_Ptr),
+                            New_Reference_To (RTE (RE_Null_Address), Loc)));
+                     else
+                        Append_To (TSD_Aggr_List,
+                          Unchecked_Convert_To (RTE (RE_Size_Ptr),
+                            Make_Attribute_Reference (Loc,
+                              Prefix => New_Reference_To (Prim, Loc),
+                              Attribute_Name => Name_Unrestricted_Access)));
+                     end if;
+
+                     exit;
+                  end if;
+
+                  Next_Elmt (Prim_Elmt);
+               end loop;
+            end;
+         end if;
+      end if;
+
       --  Interfaces_Table (required for AI-405)
 
       if RTE_Record_Component_Available (RE_Interfaces_Table) then
@@ -4561,17 +4644,11 @@ package body Exp_Disp is
       --  Initialize the table of ancestor tags. In case of interface types
       --  this table is not needed.
 
-      declare
-         Current_Typ : Entity_Id;
-         Parent_Typ  : Entity_Id;
-         Pos         : Nat;
-
-      begin
       TSD_Tags_List := New_List;
 
-         --  If we are not statically allocating the dispatch table then we
-         --  must fill position 0 with null because we still have not
-         --  generated the tag of Typ.
+      --  If we are not statically allocating the dispatch table then we must
+      --  fill position 0 with null because we still have not generated the
+      --  tag of Typ.
 
       if not Building_Static_DT (Typ)
         or else Is_Interface (Typ)
@@ -4589,6 +4666,12 @@ package body Exp_Disp is
 
       --  Fill the rest of the table with the tags of the ancestors
 
+      declare
+         Current_Typ : Entity_Id;
+         Parent_Typ  : Entity_Id;
+         Pos         : Nat;
+
+      begin
          Pos := 1;
          Current_Typ := Typ;
 
@@ -4775,6 +4858,7 @@ package body Exp_Disp is
             declare
                Prim_Table : array
                               (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
+               Decl       : Node_Id;
                E          : Entity_Id;
 
             begin
@@ -4808,26 +4892,43 @@ package body Exp_Disp is
                for J in Prim_Table'Range loop
                   if Present (Prim_Table (J)) then
                      New_Node :=
-                       Unchecked_Convert_To (RTE (RE_Address),
+                       Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                          Make_Attribute_Reference (Loc,
                            Prefix => New_Reference_To (Prim_Table (J), Loc),
                            Attribute_Name => Name_Unrestricted_Access));
                   else
-                     New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
+                     New_Node := Make_Null (Loc);
                   end if;
 
                   Append_To (Prim_Ops_Aggr_List, New_Node);
                end loop;
 
+               New_Node :=
+                 Make_Aggregate (Loc,
+                   Expressions => Prim_Ops_Aggr_List);
+
+               Decl :=
+                 Make_Subtype_Declaration (Loc,
+                   Defining_Identifier =>
+                     Make_Defining_Identifier (Loc,
+                       New_Internal_Name ('S')),
+                   Subtype_Indication =>
+                     New_Reference_To (RTE (RE_Address_Array), Loc));
+
+               Append_To (Result, Decl);
+
                Append_To (Result,
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => Predef_Prims,
                    Aliased_Present     => True,
                    Constant_Present    => Building_Static_DT (Typ),
-                   Object_Definition   =>
-                     New_Reference_To (RTE (RE_Address_Array), Loc),
-                   Expression => Make_Aggregate (Loc,
-                     Expressions => Prim_Ops_Aggr_List)));
+                   Object_Definition   => New_Reference_To
+                                           (Defining_Identifier (Decl), Loc),
+                   Expression => New_Node));
+
+               --  Remember aggregates initializing dispatch tables
+
+               Append_Elmt (New_Node, DT_Aggr);
 
                Append_To (Result,
                  Make_Attribute_Definition_Clause (Loc,
@@ -4880,9 +4981,7 @@ package body Exp_Disp is
 
          --  Offset_To_Top
 
-         if RTE_Record_Component_Available (RE_Offset_To_Top) then
          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
-         end if;
 
          --  Typeinfo
 
@@ -4896,13 +4995,11 @@ package body Exp_Disp is
          Prim_Ops_Aggr_List := New_List;
 
          if Nb_Prim = 0 then
-            Append_To (Prim_Ops_Aggr_List,
-              New_Reference_To (RTE (RE_Null_Address), Loc));
+            Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
 
          elsif not Building_Static_DT (Typ) then
             for J in 1 .. Nb_Prim loop
-               Append_To (Prim_Ops_Aggr_List,
-                 New_Reference_To (RTE (RE_Null_Address), Loc));
+               Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
             end loop;
 
          else
@@ -4951,12 +5048,12 @@ package body Exp_Disp is
                for J in Prim_Table'Range loop
                   if Present (Prim_Table (J)) then
                      New_Node :=
-                       Unchecked_Convert_To (RTE (RE_Address),
+                       Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                          Make_Attribute_Reference (Loc,
                            Prefix => New_Reference_To (Prim_Table (J), Loc),
                            Attribute_Name => Name_Unrestricted_Access));
                   else
-                     New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
+                     New_Node := Make_Null (Loc);
                   end if;
 
                   Append_To (Prim_Ops_Aggr_List, New_Node);
@@ -4964,9 +5061,15 @@ package body Exp_Disp is
             end;
          end if;
 
-         Append_To (DT_Aggr_List,
+         New_Node :=
            Make_Aggregate (Loc,
-             Expressions => Prim_Ops_Aggr_List));
+             Expressions => Prim_Ops_Aggr_List);
+
+         Append_To (DT_Aggr_List, New_Node);
+
+         --  Remember aggregates initializing dispatch tables
+
+         Append_Elmt (New_Node, DT_Aggr);
 
          --  In case of locally defined tagged types we have already declared
          --  and uninitialized object for the dispatch table, which is now
@@ -5048,26 +5151,27 @@ package body Exp_Disp is
       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
       --  in the init proc, and we don't need to fill them in here.
 
-      elsif Is_CPP_Class (Etype (Typ)) then
+      elsif Is_CPP_Class (Parent_Typ) then
          null;
 
       --  Otherwise we fill in the dispatch tables here
 
       else
-         if Typ /= Etype (Typ)
+         if Typ /= Parent_Typ
            and then not Is_Interface (Typ)
            and then not Restriction_Active (No_Dispatching_Calls)
          then
             --  Inherit the dispatch table
 
             if not Is_Interface (Typ)
-              and then not Is_Interface (Etype (Typ))
-              and then not Is_CPP_Class (Etype (Typ))
+              and then not Is_Interface (Parent_Typ)
+              and then not Is_CPP_Class (Parent_Typ)
             then
                declare
                   Nb_Prims : constant Int :=
                                UI_To_Int (DT_Entry_Count
-                                 (First_Tag_Component (Etype (Typ))));
+                                 (First_Tag_Component (Parent_Typ)));
+
                begin
                   Append_To (Elab_Code,
                     Build_Inherit_Predefined_Prims (Loc,
@@ -5076,7 +5180,7 @@ package body Exp_Disp is
                           (Node
                            (Next_Elmt
                             (First_Elmt
-                             (Access_Disp_Table (Etype (Typ))))), Loc),
+                             (Access_Disp_Table (Parent_Typ)))), Loc),
                       New_Tag_Node =>
                         New_Reference_To
                           (Node
@@ -5092,7 +5196,7 @@ package body Exp_Disp is
                            New_Reference_To
                              (Node
                               (First_Elmt
-                               (Access_Disp_Table (Etype (Typ)))), Loc),
+                               (Access_Disp_Table (Parent_Typ))), Loc),
                          New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
                          Num_Prims    => Nb_Prims));
                   end if;
@@ -5101,13 +5205,13 @@ package body Exp_Disp is
 
             --  Inherit the secondary dispatch tables of the ancestor
 
-            if not Is_CPP_Class (Etype (Typ)) then
+            if not Is_CPP_Class (Parent_Typ) then
                declare
                   Sec_DT_Ancestor : Elmt_Id :=
                                       Next_Elmt
                                        (Next_Elmt
                                         (First_Elmt
-                                          (Access_Disp_Table (Etype (Typ)))));
+                                          (Access_Disp_Table (Parent_Typ))));
                   Sec_DT_Typ      : Elmt_Id :=
                                       Next_Elmt
                                        (Next_Elmt
@@ -5327,18 +5431,49 @@ package body Exp_Disp is
            Make_Select_Specific_Data_Table (Typ));
       end if;
 
-      --  Mark entities containing library level static dispatch tables. This
-      --  attribute is later propagated to all the access-to-subprogram itypes
-      --  generated to fill the dispatch table slots (see exp_attr).
+      --  Remember entities containing dispatch tables
 
-      if Building_Static_DT (Typ) then
-         Set_Is_Static_Dispatch_Table_Entity (Predef_Prims);
-         Set_Is_Static_Dispatch_Table_Entity (DT);
-      end if;
+      Append_Elmt (Predef_Prims, DT_Decl);
+      Append_Elmt (DT, DT_Decl);
 
       Analyze_List (Result, Suppress => All_Checks);
       Set_Has_Dispatch_Table (Typ);
 
+      --  Mark entities containing dispatch tables. Required by the
+      --  backend to handle them properly.
+
+      if not Is_Interface (Typ) then
+         declare
+            Elmt : Elmt_Id;
+
+         begin
+            --  Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
+            --  the decoration required by the backend
+
+            Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
+            Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
+
+            --  Object declarations
+
+            Elmt := First_Elmt (DT_Decl);
+            while Present (Elmt) loop
+               Set_Is_Dispatch_Table_Entity (Node (Elmt));
+               pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
+                 or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
+               Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
+               Next_Elmt (Elmt);
+            end loop;
+
+            --  Aggregates initializing dispatch tables
+
+            Elmt := First_Elmt (DT_Aggr);
+            while Present (Elmt) loop
+               Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
+               Next_Elmt (Elmt);
+            end loop;
+         end;
+      end if;
+
       return Result;
    end Make_DT;
 
@@ -5763,7 +5898,7 @@ package body Exp_Disp is
       --     expand dispatching calls through the primary dispatch table.
 
       --     Generate:
-      --       type Typ_DT is array (1 .. Nb_Prims) of Address;
+      --       type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
       --       type Typ_DT_Acc is access Typ_DT;
 
       declare
@@ -5791,7 +5926,7 @@ package body Exp_Disp is
                  Component_Definition =>
                    Make_Component_Definition (Loc,
                      Subtype_Indication =>
-                       New_Reference_To (RTE (RE_Address), Loc)))));
+                       New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
 
          Append_To (Result,
            Make_Full_Type_Declaration (Loc,
@@ -5810,6 +5945,11 @@ package body Exp_Disp is
 
          Analyze_List (Result);
          Set_Suppress_Init_Proc (Base_Type (DT_Prims));
+
+         --  Mark entity of dispatch table. Required by the backend to handle
+         --  the properly.
+
+         Set_Is_Dispatch_Table_Entity (DT_Prims);
       end;
 
       Set_Ekind        (DT_Ptr, E_Constant);
@@ -5949,9 +6089,9 @@ package body Exp_Disp is
       L             : List_Id;
       Pos           : Uint;
       Tag           : Entity_Id;
+      Tag_Typ       : Entity_Id;
       Thunk_Id      : Entity_Id;
       Thunk_Code    : Node_Id;
-      Typ           : Entity_Id;
 
    begin
       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -5961,35 +6101,49 @@ package body Exp_Disp is
       end if;
 
       if not Present (Abstract_Interface_Alias (Prim)) then
-         Typ := Scope (DTC_Entity (Prim));
+         Tag_Typ := Scope (DTC_Entity (Prim));
          Pos := DT_Position (Prim);
-         Tag := First_Tag_Component (Typ);
+         Tag := First_Tag_Component (Tag_Typ);
 
          if Is_Predefined_Dispatching_Operation (Prim)
            or else Is_Predefined_Dispatching_Alias (Prim)
          then
-            DT_Ptr := Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
+            DT_Ptr :=
+              Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
+
             Insert_After (Ins_Nod,
               Build_Set_Predefined_Prim_Op_Address (Loc,
                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
                 Position     => Pos,
                 Address_Node =>
-                  Unchecked_Convert_To (RTE (RE_Address),
+                  Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                     Make_Attribute_Reference (Loc,
                       Prefix => New_Reference_To (Prim, Loc),
                       Attribute_Name => Name_Unrestricted_Access))));
 
+            --  Register copy of the pointer to the 'size primitive in the TSD.
+
+            if Chars (Prim) = Name_uSize
+              and then RTE_Record_Component_Available (RE_Size_Func)
+            then
+               DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
+               Insert_After (Ins_Nod,
+                 Build_Set_Size_Function (Loc,
+                   Tag_Node  => New_Reference_To (DT_Ptr, Loc),
+                   Size_Func => Prim));
+            end if;
+
          else
             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
 
-            DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
+            DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
             Insert_After (Ins_Nod,
               Build_Set_Prim_Op_Address (Loc,
-                Typ          => Typ,
+                Typ          => Tag_Typ,
                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
                 Position     => Pos,
                 Address_Node =>
-                  Unchecked_Convert_To (RTE (RE_Address),
+                  Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                     Make_Attribute_Reference (Loc,
                       Prefix => New_Reference_To (Prim, Loc),
                       Attribute_Name => Name_Unrestricted_Access))));
@@ -6002,14 +6156,14 @@ package body Exp_Disp is
       --  else to do here.
 
       else
-         Typ       := Find_Dispatching_Type (Alias (Prim));
+         Tag_Typ   := Find_Dispatching_Type (Alias (Prim));
          Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
 
          pragma Assert (Is_Interface (Iface_Typ));
 
          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
 
-         if not Is_Parent (Iface_Typ, Typ)
+         if not Is_Parent (Iface_Typ, Tag_Typ)
            and then Present (Thunk_Code)
          then
             --  Comment needed on why checks are suppressed. This is not just
@@ -6022,7 +6176,7 @@ package body Exp_Disp is
             --  the secondary dispatch table of Prim's controlling type with
             --  Thunk_Id's address.
 
-            Iface_DT_Elmt := Find_Interface_ADT (Typ, Iface_Typ);
+            Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
             Iface_DT_Ptr  := Node (Iface_DT_Elmt);
             pragma Assert (Has_Thunks (Iface_DT_Ptr));
 
@@ -6040,7 +6194,7 @@ package body Exp_Disp is
                      New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
                    Position => Pos,
                    Address_Node =>
-                     Unchecked_Convert_To (RTE (RE_Address),
+                     Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
                          Prefix          => New_Reference_To (Thunk_Id, Loc),
                          Attribute_Name  => Name_Unrestricted_Access))));
@@ -6056,7 +6210,7 @@ package body Exp_Disp is
                      New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
                    Position => Pos,
                    Address_Node =>
-                     Unchecked_Convert_To (RTE (RE_Address),
+                     Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
                          Prefix => New_Reference_To (Alias (Prim), Loc),
                          Attribute_Name  => Name_Unrestricted_Access))));
@@ -6073,7 +6227,7 @@ package body Exp_Disp is
                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
                    Position     => Pos,
                    Address_Node =>
-                     Unchecked_Convert_To (RTE (RE_Address),
+                     Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
                          Prefix => New_Reference_To (Thunk_Id, Loc),
                          Attribute_Name => Name_Unrestricted_Access))));
@@ -6089,7 +6243,7 @@ package body Exp_Disp is
                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
                    Position     => Pos,
                    Address_Node =>
-                     Unchecked_Convert_To (RTE (RE_Address),
+                     Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
                          Prefix => New_Reference_To (Alias (Prim), Loc),
                          Attribute_Name => Name_Unrestricted_Access))));

gcc/ada/rtsfind.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -283,6 +283,9 @@ package body Rtsfind is
          if U_Id in Ada_Calendar_Child then
             Name_Buffer (13) := '.';
 
+         elsif U_Id in Ada_Dispatching_Child then
+            Name_Buffer (16) := '.';
+
          elsif U_Id in Ada_Finalization_Child then
             Name_Buffer (17) := '.';
 
@@ -311,6 +314,10 @@ package body Rtsfind is
       elsif U_Id in System_Child then
          Name_Buffer (7) := '.';
 
+         if U_Id in System_Strings_Child then
+            Name_Buffer (15) := '.';
+         end if;
+
          if U_Id in System_Tasking_Child then
             Name_Buffer (15) := '.';
          end if;

gcc/ada/rtsfind.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -78,6 +78,9 @@ package Rtsfind is
    --    name is System.xxx. For example, the name System_Str_Concat refers to
    --    package System.Str_Concat.
 
+   --    Names of the form System_Strings_xxx are second level children of the
+   --    package System.Strings.
+
    --    Names of the form System_Tasking_xxx are second level children of the
    --    package System.Tasking. For example, System_Tasking_Stages refers to
    --    refers to the package System.Tasking.Stages.
@@ -112,6 +115,7 @@ package Rtsfind is
       --  Children of Ada
 
       Ada_Calendar,
+      Ada_Dispatching,
       Ada_Exceptions,
       Ada_Finalization,
       Ada_Interrupts,
@@ -125,6 +129,10 @@ package Rtsfind is
 
       Ada_Calendar_Delays,
 
+      --  Children of Ada.Dispatching
+
+      Ada_Dispatching_EDF,
+
       --  Children of Ada.Finalization
 
       Ada_Finalization_List_Controller,
@@ -348,6 +356,10 @@ package Rtsfind is
       System_WWd_Enum,
       System_WWd_Wchar,
 
+      --  Children of System.Strings
+
+      System_Strings_Stream_Ops,
+
       --  Children of System.Tasking
 
       System_Tasking_Async_Delays,
@@ -369,6 +381,10 @@ package Rtsfind is
      range Ada_Calendar_Delays .. Ada_Calendar_Delays;
    --  Range of values for children of Ada.Calendar
 
+   subtype Ada_Dispatching_Child is RTU_Id
+     range Ada_Dispatching_EDF .. Ada_Dispatching_EDF;
+   --  Range of values for children of Ada.Dispatching
+
    subtype Ada_Finalization_Child is Ada_Child range
      Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller;
    --  Range of values for children of Ada.Finalization
@@ -404,6 +420,9 @@ package Rtsfind is
      range System_Address_Image .. System_Tasking_Stages;
    --  Range of values for children or grandchildren of System
 
+   subtype System_Strings_Child is RTU_Id
+     range System_Strings_Stream_Ops .. System_Strings_Stream_Ops;
+
    subtype System_Tasking_Child is System_Child
      range System_Tasking_Async_Delays .. System_Tasking_Stages;
    --  Range of values for children of System.Tasking
@@ -451,6 +470,8 @@ package Rtsfind is
 
      RE_Null,
 
+     RE_Set_Deadline,                    -- Ada.Dispatching.EDF
+
      RE_Code_Loc,                        -- Ada.Exceptions
      RE_Current_Target_Exception,        -- Ada.Exceptions (JGNAT use only)
      RE_Exception_Id,                    -- Ada.Exceptions
@@ -497,6 +518,7 @@ package Rtsfind is
      RE_Dispatch_Table_Wrapper,          -- Ada.Tags
      RE_Displace,                        -- Ada.Tags
      RE_DT,                              -- Ada.Tags
+     RE_DT_Offset_To_Top_Offset,         -- Ada.Tags
      RE_DT_Predef_Prims_Offset,          -- Ada.Tags
      RE_DT_Typeinfo_Ptr_Size,            -- Ada.Tags
      RE_External_Tag,                    -- Ada.Tags
@@ -520,6 +542,7 @@ package Rtsfind is
      RE_Num_Prims,                       -- Ada.Tags
      RE_Object_Specific_Data,            -- Ada.Tags
      RE_Offset_To_Top,                   -- Ada.Tags
+     RE_Offset_To_Top_Ptr,               -- Ada.Tags
      RE_Offset_To_Top_Function_Ptr,      -- Ada.Tags
      RE_OSD_Table,                       -- Ada.Tags
      RE_OSD_Num_Prims,                   -- Ada.Tags
@@ -534,20 +557,24 @@ package Rtsfind is
      RE_Predef_Prims,                    -- Ada.Tags
      RE_Predef_Prims_Table_Ptr,          -- Ada.Tags
      RE_Prim_Op_Kind,                    -- Ada.Tags
+     RE_Prim_Ptr,                        -- Ada.Tags
      RE_Prims_Ptr,                       -- Ada.Tags
      RE_Primary_DT,                      -- Ada.Tags
      RE_Signature,                       -- Ada.Tags
      RE_SSD,                             -- Ada.Tags
      RE_TSD,                             -- Ada.Tags
      RE_Type_Specific_Data,              -- Ada.Tags
+     RE_Register_Interface_Offset,       -- Ada.Tags
      RE_Register_Tag,                    -- Ada.Tags
      RE_Transportable,                   -- Ada.Tags
      RE_Secondary_DT,                    -- Ada.Tags
      RE_Secondary_Tag,                   -- Ada.Tags
      RE_Select_Specific_Data,            -- Ada.Tags
      RE_Set_Entry_Index,                 -- Ada.Tags
-     RE_Set_Offset_To_Top,               -- Ada.Tags
+     RE_Set_Dynamic_Offset_To_Top,       -- Ada.Tags
      RE_Set_Prim_Op_Kind,                -- Ada.Tags
+     RE_Size_Func,                       -- Ada.Tags
+     RE_Size_Ptr,                        -- Ada.Tags
      RE_Tag,                             -- Ada.Tags
      RE_Tag_Error,                       -- Ada.Tags
      RE_Tag_Kind,                        -- Ada.Tags
@@ -573,6 +600,9 @@ package Rtsfind is
      RO_CA_Delay_Until,                  -- Ada.Calendar.Delays
      RO_CA_To_Duration,                  -- Ada.Calendar.Delays
 
+     RE_Clock,                           -- Ada.Real_Time
+     RE_Time_Span,                       -- Ada.Real_Time
+     RE_Time_Span_Zero,                  -- Ada.Real_Time
      RO_RT_Time,                         -- Ada.Real_Time
 
      RO_RT_Delay_Until,                  -- Ada.Real_Time.Delays
@@ -749,6 +779,7 @@ package Rtsfind is
      RE_Default_Interrupt_Priority,      -- System.Interrupts
      RE_Dynamic_Interrupt_Protection,    -- System.Interrupts
      RE_Install_Handlers,                -- System.Interrupts
+     RE_Install_Restricted_Handlers,     -- System.Interrupts
      RE_Register_Interrupt_Handler,      -- System.Interrupts
      RE_Static_Interrupt_Protection,     -- System.Interrupts
      RE_System_Interrupt_Id,             -- System.Interrupts
@@ -1233,11 +1264,10 @@ package Rtsfind is
      RE_Storage_Offset,                  -- System.Storage_Elements
      RE_Storage_Array,                   -- System.Storage_Elements
      RE_To_Address,                      -- System.Storage_Elements
-     RE_Dummy_Communication_Block,       -- System.Storage_Elements
 
      RE_Root_Storage_Pool,               -- System.Storage_Pools
-     RE_Allocate_Any,                    -- System_Storage_Pools,
-     RE_Deallocate_Any,                  -- System_Storage_Pools,
+     RE_Allocate_Any,                    -- System.Storage_Pools,
+     RE_Deallocate_Any,                  -- System.Storage_Pools,
 
      RE_I_AD,                            -- System.Stream_Attributes
      RE_I_AS,                            -- System.Stream_Attributes
@@ -1292,6 +1322,19 @@ package Rtsfind is
 
      RE_Str_Concat_5,                    -- System.String_Ops_Concat_5
 
+     RE_String_Input,                    -- System.Strings.Stream_Ops
+     RE_String_Output,                   -- System.Strings.Stream_Ops
+     RE_String_Read,                     -- System.Strings.Stream_Ops
+     RE_String_Write,                    -- System.Strings.Stream_Ops
+     RE_Wide_String_Input,               -- System.Strings.Stream_Ops
+     RE_Wide_String_Output,              -- System.Strings.Stream_Ops
+     RE_Wide_String_Read,                -- System.Strings.Stream_Ops
+     RE_Wide_String_Write,               -- System.Strings.Stream_Ops
+     RE_Wide_Wide_String_Input,          -- System.Strings.Stream_Ops
+     RE_Wide_Wide_String_Output,         -- System.Strings.Stream_Ops
+     RE_Wide_Wide_String_Read,           -- System.Strings.Stream_Ops
+     RE_Wide_Wide_String_Write,          -- System.Strings.Stream_Ops
+
      RE_Task_Info_Type,                  -- System.Task_Info
      RE_Unspecified_Task_Info,           -- System.Task_Info
 
@@ -1331,6 +1374,7 @@ package Rtsfind is
      RE_Abort_Undefer,                   -- System.Soft_Links
      RE_Complete_Master,                 -- System.Soft_Links
      RE_Current_Master,                  -- System.Soft_Links
+     RE_Dummy_Communication_Block,       -- System.Soft_Links
      RE_Enter_Master,                    -- System.Soft_Links
      RE_Get_Current_Excep,               -- System.Soft_Links
      RE_Get_GNAT_Exception,              -- System.Soft_Links
@@ -1555,6 +1599,8 @@ package Rtsfind is
 
      RE_Null                             => RTU_Null,
 
+     RE_Set_Deadline                     => Ada_Dispatching_EDF,
+
      RE_Code_Loc                         => Ada_Exceptions,
      RE_Current_Target_Exception         => Ada_Exceptions, -- of JGNAT
      RE_Exception_Id                     => Ada_Exceptions,
@@ -1601,6 +1647,7 @@ package Rtsfind is
      RE_Dispatch_Table_Wrapper           => Ada_Tags,
      RE_Displace                         => Ada_Tags,
      RE_DT                               => Ada_Tags,
+     RE_DT_Offset_To_Top_Offset          => Ada_Tags,
      RE_DT_Predef_Prims_Offset           => Ada_Tags,
      RE_DT_Typeinfo_Ptr_Size             => Ada_Tags,
      RE_External_Tag                     => Ada_Tags,
@@ -1624,6 +1671,7 @@ package Rtsfind is
      RE_Num_Prims                        => Ada_Tags,
      RE_Object_Specific_Data             => Ada_Tags,
      RE_Offset_To_Top                    => Ada_Tags,
+     RE_Offset_To_Top_Ptr                => Ada_Tags,
      RE_Offset_To_Top_Function_Ptr       => Ada_Tags,
      RE_OSD_Table                        => Ada_Tags,
      RE_OSD_Num_Prims                    => Ada_Tags,
@@ -1638,20 +1686,24 @@ package Rtsfind is
      RE_Predef_Prims                     => Ada_Tags,
      RE_Predef_Prims_Table_Ptr           => Ada_Tags,
      RE_Prim_Op_Kind                     => Ada_Tags,
+     RE_Prim_Ptr                         => Ada_Tags,
      RE_Prims_Ptr                        => Ada_Tags,
      RE_Primary_DT                       => Ada_Tags,
      RE_Signature                        => Ada_Tags,
      RE_SSD                              => Ada_Tags,
      RE_TSD                              => Ada_Tags,
      RE_Type_Specific_Data               => Ada_Tags,
+     RE_Register_Interface_Offset        => Ada_Tags,
      RE_Register_Tag                     => Ada_Tags,
      RE_Transportable                    => Ada_Tags,
      RE_Secondary_DT                     => Ada_Tags,
      RE_Secondary_Tag                    => Ada_Tags,
      RE_Select_Specific_Data             => Ada_Tags,
      RE_Set_Entry_Index                  => Ada_Tags,
-     RE_Set_Offset_To_Top                => Ada_Tags,
+     RE_Set_Dynamic_Offset_To_Top        => Ada_Tags,
      RE_Set_Prim_Op_Kind                 => Ada_Tags,
+     RE_Size_Func                        => Ada_Tags,
+     RE_Size_Ptr                         => Ada_Tags,
      RE_Tag                              => Ada_Tags,
      RE_Tag_Error                        => Ada_Tags,
      RE_Tag_Kind                         => Ada_Tags,
@@ -1676,6 +1728,9 @@ package Rtsfind is
      RO_CA_Delay_Until                   => Ada_Calendar_Delays,
      RO_CA_To_Duration                   => Ada_Calendar_Delays,
 
+     RE_Clock                            => Ada_Real_Time,
+     RE_Time_Span                        => Ada_Real_Time,
+     RE_Time_Span_Zero                   => Ada_Real_Time,
      RO_RT_Time                          => Ada_Real_Time,
      RO_RT_Delay_Until                   => Ada_Real_Time_Delays,
      RO_RT_To_Duration                   => Ada_Real_Time_Delays,
@@ -1851,6 +1906,7 @@ package Rtsfind is
      RE_Default_Interrupt_Priority       => System_Interrupts,
      RE_Dynamic_Interrupt_Protection     => System_Interrupts,
      RE_Install_Handlers                 => System_Interrupts,
+     RE_Install_Restricted_Handlers      => System_Interrupts,
      RE_Register_Interrupt_Handler       => System_Interrupts,
      RE_Static_Interrupt_Protection      => System_Interrupts,
      RE_System_Interrupt_Id              => System_Interrupts,
@@ -2335,7 +2391,6 @@ package Rtsfind is
      RE_Storage_Offset                   => System_Storage_Elements,
      RE_Storage_Array                    => System_Storage_Elements,
      RE_To_Address                       => System_Storage_Elements,
-     RE_Dummy_Communication_Block        => System_Storage_Elements,
 
      RE_Root_Storage_Pool                => System_Storage_Pools,
      RE_Allocate_Any                     => System_Storage_Pools,
@@ -2394,6 +2449,19 @@ package Rtsfind is
 
      RE_Str_Concat_5                     => System_String_Ops_Concat_5,
 
+     RE_String_Input                     => System_Strings_Stream_Ops,
+     RE_String_Output                    => System_Strings_Stream_Ops,
+     RE_String_Read                      => System_Strings_Stream_Ops,
+     RE_String_Write                     => System_Strings_Stream_Ops,
+     RE_Wide_String_Input                => System_Strings_Stream_Ops,
+     RE_Wide_String_Output               => System_Strings_Stream_Ops,
+     RE_Wide_String_Read                 => System_Strings_Stream_Ops,
+     RE_Wide_String_Write                => System_Strings_Stream_Ops,
+     RE_Wide_Wide_String_Input           => System_Strings_Stream_Ops,
+     RE_Wide_Wide_String_Output          => System_Strings_Stream_Ops,
+     RE_Wide_Wide_String_Read            => System_Strings_Stream_Ops,
+     RE_Wide_Wide_String_Write           => System_Strings_Stream_Ops,
+
      RE_Task_Info_Type                   => System_Task_Info,
      RE_Unspecified_Task_Info            => System_Task_Info,
 
@@ -2433,6 +2501,7 @@ package Rtsfind is
      RE_Abort_Undefer                    => System_Soft_Links,
      RE_Complete_Master                  => System_Soft_Links,
      RE_Current_Master                   => System_Soft_Links,
+     RE_Dummy_Communication_Block        => System_Soft_Links,
      RE_Enter_Master                     => System_Soft_Links,
      RE_Get_Current_Excep                => System_Soft_Links,
      RE_Get_GNAT_Exception               => System_Soft_Links,