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

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

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

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

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

From-SVN: r106965

gcc/ada/exp_ch3.ads

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

gcc/ada/exp_ch7.adb

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

gcc/ada/exp_ch9.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -311,13 +311,21 @@ package Exp_Ch9 is
    --  protected type.
 
    procedure Set_Privals
-      (Dec : Node_Id;
-       Op  : Node_Id;
-       Loc : Source_Ptr);
+      (Dec           : Node_Id;
+       Op            : Node_Id;
+       Loc           : Source_Ptr;
+       After_Barrier : Boolean := False);
    --  Associates a new set of privals (placeholders for later access to
    --  private components of protected objects) with the private object
    --  declarations of a protected object. These will be used to expand
    --  the references to private objects in the next protected
    --  subprogram or entry body to be expanded.
+   --
+   --  The flag After_Barrier indicates whether this is called after building
+   --  the barrier function for an entry body. This flag determines whether
+   --  the privals should have source names (which simplifies debugging) or
+   --  internally generated names. Entry barriers contain no debuggable code,
+   --  and there may be visibility conflicts between an entry index and a
+   --  a prival, so  privals for barrier function have internal names.
 
 end Exp_Ch9;

gcc/ada/exp_dbug.adb

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

gcc/ada/exp_dbug.ads

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

gcc/ada/exp_util.ads

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

gcc/ada/snames.adb

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