exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the run-time subprogram Set_External_Tag by call to...

2007-04-06  Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the
	run-time subprogram Set_External_Tag by call to Build_Set_External_Tag.

	* exp_ch4.adb (Expand_Allocator_Expression): Don't perform a run-time
	accessibility on class-wide allocators if the allocator occurs at the
	same scope level as the allocator's type. The check is guaranteed to
	succeed in that case, even when the expression originates from a
	parameter of the containing subprogram.
	(Expand_N_Op_Eq): Do nothing in case of dispatching call if compiling
	under No_Dispatching_Calls restriction. During the semantic analysis
	we already notified such violation.
	(Tagged_Membership): Constant folding. There is no need to check
	the tag at run-time if the type of the right operand is non
	class-wide abstract.
	Replace call to Is_Ancestor by call to Is_Parent
	to support concurrent types with interface types.
	(Expand_N_Allocator): Add an assertion associated with the generation
	of the master_id.
	(Expand_N_Slice): Do not enable range check to nodes associated
	with the frontend expansion of the dispatch table.
	(Is_Local_Access_Discriminant): Subsidiary function to
	Expand_N_Allocator.
	(Tagged_Membership): Replace generation of call to the run-time
	subprogram CW_Membership by call to Build_CW_Membership.
	(Expand_Allocator_Expression): Replace generation of call to the
	run-time subprogram Get_Access_Level by call to Build_Get_Access_Level.

	* exp_disp.ads, exp_disp.adb (Make_DT): Code reorganization to
	initialize most the TSD components by means of an aggregate.
	Modify the declaration of the object containing the TSD
	because we now expand code that has a higher level of abstraction.
	The TSD has a discriminant containing the Inheritance Depth Level,
	value that is used in the membership test but also to fix the size
	of the table of ancestors.
	(Expand_Interface_Conversion): Insert function body at the closest place
	to the conversion expression, to prevent access-before-elaboration
	errors in the backend.
	Code improved to reduce the size of the dispatch table if
	compiling under restriction No_Dispatching_Calls plus code cleanup.
	Code reorganization plus removal of calls to Set_Num_Prim_Ops
	(Make_Secondary_DT): Remove call to Set_Num_Prim_Ops.
	(Expand_Dispatching_Call): Minor code reorganization plus addition of
	code to return immediately if compiling under No_Dispatching_Calls
	restriction.
	(Set_All_DT_Position): Remove code associated with the old CPP pragmas.
	CPP_Virtual and CPP_Vtable are no longer supported.
	(Expand_Interface_Conversion): Add missing support for interface type
	derivations.
	(Expand_Interface_Actuals): Replace calls to Is_Ancestor by calls to
	Is_Parent to support concurrent types with interfaces.
	(Init_Predefined_Interface_Primitives): Removed.
	(Make_Secondary_DT): Modified to support concurrent record types.
	(Set_All_DT_Position): Modified to support concurrent record types.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entries associated
	with Get_External_Tag, Inherit_TSD, Set_External_Tag.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entry associated
	with CW_Membership.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entries associated
	with Get_Access_Level, Get_Predefined_Prim_Op_Address,
	Get_Prim_Op_Address Get_RC_Offset, Get_Remotely_Callable, Inherit_DT,
	Set_Access_Level, Set_Expanded_Name, Set_Predefined_Prim_Op_Address,
	Set_Prim_Op_Address, Set_RC_Offset, Set_Remotely_Callable, Set_TSD.
	(Expand_Dispatching_Call): Replace generation of call to the run-time
	subprograms Get_Predefined_Prim_Op_Address and Get_Prim_Op_Address by
	calls to Build_Get_Predefined_Prim_Op_Address, and Build_Get_Prim_Op_
	Address.
	(Fill_DT_Entry, Fill_Secondary_DT_Entry): Replace generation of call to
	the run-time subprograms Set_Predefined_Prim_Op_Address and Set_Prim_
	Op_Address by calls to Build_Set_Predefined_Prim_Op_Address, and
	Build_Set_Prim_Op_Address.
	(Get_Remotely_Callable): Subprogram removed.
	(Init_Predefined_Interface_Primitives): Replace generation of call to
	the run-time subprograms Inherit_DT by call to Build_Inherit_Predefined_
	Prims.

	* sem_elab.adb (Set_Elaboration_Constraint): Replace the call to
	First (Parameter_Associations ()) with the call to First_Actual that
	returns an actual parameter expression for both named and positional
	associations.

	* sem_disp.adb (Check_Dispatching_Call): In case of dispatching call
	check violation of restriction No_Dispatching_Calls.
	(Check_Controlling_Type): A formal of a tagged incomplete type is a
	controlling argument.

	* exp_util.ads, exp_util.adb (Type_May_Have_Bit_Aligned_Components): Use
	First/Next_Component_Or_Discriminant
	(Insert_Actions): Add entries for new N_Push and N_Pop nodes
	(Find_Implemented_Interface): Removed. All the calls to this subprogram
	specify Any_Limited_Interface, and this functionality is already
	provided by the function Has_Abstract_Interfaces.
	(Find_Interface, Find_Interface_Tag, Find_Interface_ADT): Modified to
	support concurrent types implementing interfaces.
	(Find_Implemented_Interface): Removed. All the calls to this subprogram
	specify kind Any_Limited_Interface, and this functionality is already
	provided by the function Has_Abstract_Interfaces.
	(Remove_Side_Effects): replace Controlled_Type by
	CW_Or_Controlled_Type whenever the issue is related to
	using or not the secondary stack.

	* par-ch12.adb (P_Formal_Type_Definition): Update calls to
	P_Interface_Type_Definition to fulfill the new interface (the formal
	Is_Synchronized is no longer required).

	* Make-lang.in (GNAT_ADA_OBJS): Addition of exp_atag.o
	Update dependencies.

	* exp_atag.ads, exp_atag.adb: New file

From-SVN: r123562

1 files changed, 130 insertions, 190 deletions

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 13878a3..5e938aa 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1303,145 +1303,6 @@ package body Exp_Util is
       end if;
    end Expand_Subtype_From_Expr;
 
-   --------------------------------
-   -- Find_Implemented_Interface --
-   --------------------------------
-
-   --  Given the following code (XXX denotes irrelevant value):
-
-   --     type Limd_Iface is limited interface;
-   --     type Prot_Iface is protected interface;
-   --     type Sync_Iface is synchronized interface;
-
-   --     type Parent_Subtype is new Limd_Iface and Sync_Iface with ...
-   --     type Child_Subtype is new Parent_Subtype and Prot_Iface with ...
-
-   --  The following calls will return the following values:
-
-   --     Find_Implemented_Interface
-   --       (Child_Subtype, Synchronized_Interface, False)    -> Empty
-
-   --     Find_Implemented_Interface
-   --       (Child_Subtype, Synchronized_Interface, True)     -> Sync_Iface
-
-   --     Find_Implemented_Interface
-   --       (Child_Subtype, Any_Synchronized_Interface, XXX)  -> Prot_Iface
-
-   --     Find_Implemented_Interface
-   --       (Child_Subtype, Any_Limited_Interface, XXX)       -> Prot_Iface
-
-   function Find_Implemented_Interface
-     (Typ          : Entity_Id;
-      Kind         : Interface_Kind;
-      Check_Parent : Boolean := False) return Entity_Id
-   is
-      Iface_Elmt : Elmt_Id;
-
-      function Interface_In_Kind
-        (I    : Entity_Id;
-         Kind : Interface_Kind) return Boolean;
-      --  Determine whether an interface falls into a specified kind
-
-      -----------------------
-      -- Interface_In_Kind --
-      -----------------------
-
-      function Interface_In_Kind
-        (I    : Entity_Id;
-         Kind : Interface_Kind) return Boolean is
-      begin
-         if Is_Limited_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Any_Limited_Interface
-             or else Kind = Limited_Interface)
-         then
-            return True;
-
-         elsif Is_Protected_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Any_Limited_Interface
-             or else Kind = Any_Synchronized_Interface
-             or else Kind = Protected_Interface)
-         then
-            return True;
-
-         elsif Is_Synchronized_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Any_Limited_Interface
-             or else Kind = Synchronized_Interface)
-         then
-            return True;
-
-         elsif Is_Task_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Any_Limited_Interface
-             or else Kind = Any_Synchronized_Interface
-             or else Kind = Task_Interface)
-         then
-            return True;
-
-         --  Regular interface. This should be the last kind to check since
-         --  all of the previous cases have their Is_Interface flags set.
-
-         elsif Is_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Iface)
-         then
-            return True;
-
-         else
-            return False;
-         end if;
-      end Interface_In_Kind;
-
-   --  Start of processing for Find_Implemented_Interface
-
-   begin
-      if not Is_Tagged_Type (Typ) then
-         return Empty;
-      end if;
-
-      --  Implementations of the form:
-      --    Typ is new Interface ...
-
-      if Is_Interface (Etype (Typ))
-        and then Interface_In_Kind (Etype (Typ), Kind)
-      then
-         return Etype (Typ);
-      end if;
-
-      --  Implementations of the form:
-      --     Typ is new Typ_Parent and Interface ...
-
-      if Present (Abstract_Interfaces (Typ)) then
-         Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
-         while Present (Iface_Elmt) loop
-            if Interface_In_Kind (Node (Iface_Elmt), Kind) then
-               return Node (Iface_Elmt);
-            end if;
-
-            Iface_Elmt := Next_Elmt (Iface_Elmt);
-         end loop;
-      end if;
-
-      --  Typ is a derived type and may implement a limited interface
-      --  through its parent subtype. Check the parent subtype as well
-      --  as any interfaces explicitly implemented at this level.
-
-      if Check_Parent
-        and then Ekind (Typ) = E_Record_Type
-        and then Present (Parent_Subtype (Typ))
-      then
-         return Find_Implemented_Interface (
-           Parent_Subtype (Typ), Kind, Check_Parent);
-      end if;
-
-      --  Typ does not implement a limited interface either at this level or
-      --  in any of its parent subtypes.
-
-      return Empty;
-   end Find_Implemented_Interface;
-
    ------------------------
    -- Find_Interface_ADT --
    ------------------------
@@ -1466,9 +1327,22 @@ package body Exp_Util is
          AI      : Node_Id;
 
       begin
-         --  Climb to the ancestor (if any) handling private types
+         pragma Assert (Typ /= Iface);
+
+         --  Climb to the ancestor (if any) handling synchronized interface
+         --  derivations and private types
+
+         if Is_Concurrent_Record_Type (Typ) then
+            declare
+               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+
+            begin
+               if Is_Non_Empty_List (Iface_List) then
+                  Find_Secondary_Table (Etype (First (Iface_List)));
+               end if;
+            end;
 
-         if Present (Full_View (Etype (Typ))) then
+         elsif Present (Full_View (Etype (Typ))) then
             if Full_View (Etype (Typ)) /= Typ then
                Find_Secondary_Table (Full_View (Etype (Typ)));
             end if;
@@ -1477,13 +1351,10 @@ package body Exp_Util is
             Find_Secondary_Table (Etype (Typ));
          end if;
 
-         --  If we already found it there is nothing else to do
-
-         if Found then
-            return;
-         end if;
+         --  Traverse the list of interfaces implemented by the type
 
-         if Present (Abstract_Interfaces (Typ))
+         if not Found
+           and then Present (Abstract_Interfaces (Typ))
            and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
          then
             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
@@ -1501,9 +1372,11 @@ package body Exp_Util is
          end if;
       end Find_Secondary_Table;
 
-   --  Start of processing for Find_Interface_Tag
+   --  Start of processing for Find_Interface_ADT
 
    begin
+      pragma Assert (Is_Interface (Iface));
+
       --  Handle private types
 
       if Has_Private_Declaration (Typ)
@@ -1520,12 +1393,14 @@ package body Exp_Util is
 
       --  Handle task and protected types implementing interfaces
 
-      if Ekind (Typ) = E_Protected_Type
-        or else Ekind (Typ) = E_Task_Type
-      then
+      if Is_Concurrent_Type (Typ) then
          Typ := Corresponding_Record_Type (Typ);
       end if;
 
+      pragma Assert
+        (not Is_Class_Wide_Type (Typ)
+          and then Ekind (Typ) /= E_Incomplete_Type);
+
       ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
       pragma Assert (Present (Node (ADT)));
       Find_Secondary_Table (Typ);
@@ -1538,13 +1413,21 @@ package body Exp_Util is
    ------------------------
 
    function Find_Interface_Tag
-     (T      : Entity_Id;
-      Iface  : Entity_Id) return Entity_Id
+     (T     : Entity_Id;
+      Iface : Entity_Id) return Entity_Id
    is
       AI_Tag : Entity_Id;
-      Found  : Boolean := False;
+      Found  : Boolean   := False;
       Typ    : Entity_Id := T;
 
+      Is_Primary_Tag : Boolean := False;
+
+      Is_Sync_Typ : Boolean := False;
+      --  In case of non concurrent-record-types each parent-type has the
+      --  tags associated with the interface types that are not implemented
+      --  by the ancestors; concurrent-record-types have their whole list of
+      --  interface tags (and this case requires some special management).
+
       procedure Find_Tag (Typ : Entity_Id);
       --  Internal subprogram used to recursively climb to the ancestors
 
@@ -1561,15 +1444,32 @@ package body Exp_Util is
          --  therefore shares the main tag.
 
          if Typ = Iface then
-            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
-            AI_Tag := First_Tag_Component (Typ);
+            if Is_Sync_Typ then
+               Is_Primary_Tag := True;
+            else
+               pragma Assert
+                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+               AI_Tag := First_Tag_Component (Typ);
+            end if;
+
             Found  := True;
             return;
          end if;
 
+         --  Handle synchronized interface derivations
+
+         if Is_Concurrent_Record_Type (Typ) then
+            declare
+               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+            begin
+               if Is_Non_Empty_List (Iface_List) then
+                  Find_Tag (Etype (First (Iface_List)));
+               end if;
+            end;
+
          --  Climb to the root type handling private types
 
-         if Present (Full_View (Etype (Typ))) then
+         elsif Present (Full_View (Etype (Typ))) then
             if Full_View (Etype (Typ)) /= Typ then
                Find_Tag (Full_View (Etype (Typ)));
             end if;
@@ -1586,9 +1486,12 @@ package body Exp_Util is
          then
             --  Skip the tag associated with the primary table
 
-            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
-            AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
-            pragma Assert (Present (AI_Tag));
+            if not Is_Sync_Typ then
+               pragma Assert
+                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+               AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+               pragma Assert (Present (AI_Tag));
+            end if;
 
             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
             while Present (AI_Elmt) loop
@@ -1641,9 +1544,25 @@ package body Exp_Util is
          Typ := Non_Limited_View (Typ);
       end if;
 
-      Find_Tag (Typ);
-      pragma Assert (Found);
-      return AI_Tag;
+      if not Is_Concurrent_Record_Type (Typ) then
+         Find_Tag (Typ);
+         pragma Assert (Found);
+         return AI_Tag;
+
+      --  Concurrent record types
+
+      else
+         Is_Sync_Typ := True;
+         AI_Tag      := Next_Tag_Component (First_Tag_Component (Typ));
+         Find_Tag (Typ);
+         pragma Assert (Found);
+
+         if Is_Primary_Tag then
+            return First_Tag_Component (Typ);
+         else
+            return AI_Tag;
+         end if;
+      end if;
    end Find_Interface_Tag;
 
    --------------------
@@ -1659,6 +1578,12 @@ package body Exp_Util is
       Iface  : Entity_Id;
       Typ    : Entity_Id := T;
 
+      Is_Sync_Typ : Boolean := False;
+      --  In case of non concurrent-record-types each parent-type has the
+      --  tags associated with the interface types that are not implemented
+      --  by the ancestors; concurrent-record-types have their whole list of
+      --  interface tags (and this case requires some special management).
+
       procedure Find_Iface (Typ : Entity_Id);
       --  Internal subprogram used to recursively climb to the ancestors
 
@@ -1672,7 +1597,21 @@ package body Exp_Util is
       begin
          --  Climb to the root type
 
-         if Etype (Typ) /= Typ then
+         --  Handle sychronized interface derivations
+
+         if Is_Concurrent_Record_Type (Typ) then
+            declare
+               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+            begin
+               if Is_Non_Empty_List (Iface_List) then
+                  Find_Iface (Etype (First (Iface_List)));
+               end if;
+            end;
+
+         --  Handle the common case
+
+         elsif Etype (Typ) /= Typ then
+            pragma Assert (not Present (Full_View (Etype (Typ))));
             Find_Iface (Etype (Typ));
          end if;
 
@@ -1684,9 +1623,12 @@ package body Exp_Util is
          then
             --  Skip the tag associated with the primary table
 
-            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
-            AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
-            pragma Assert (Present (AI_Tag));
+            if not Is_Sync_Typ then
+               pragma Assert
+                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+               AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+               pragma Assert (Present (AI_Tag));
+            end if;
 
             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
             while Present (AI_Elmt) loop
@@ -1736,6 +1678,11 @@ package body Exp_Util is
          Typ := Non_Limited_View (Typ);
       end if;
 
+      if Is_Concurrent_Record_Type (Typ) then
+         Is_Sync_Typ := True;
+         AI_Tag      := Next_Tag_Component (First_Tag_Component (Typ));
+      end if;
+
       Find_Iface (Typ);
       pragma Assert (Found);
       return Iface;
@@ -1780,6 +1727,10 @@ package body Exp_Util is
       return Node (Prim);
    end Find_Prim_Op;
 
+   ------------------
+   -- Find_Prim_Op --
+   ------------------
+
    function Find_Prim_Op
      (T    : Entity_Id;
       Name : TSS_Name_Type) return Entity_Id
@@ -2177,18 +2128,6 @@ package body Exp_Util is
       return Count;
    end Homonym_Number;
 
-   --------------------------
-   -- Implements_Interface --
-   --------------------------
-
-   function Implements_Interface
-     (Typ          : Entity_Id;
-      Kind         : Interface_Kind;
-      Check_Parent : Boolean := False) return Boolean is
-   begin
-      return Find_Implemented_Interface (Typ, Kind, Check_Parent) /= Empty;
-   end Implements_Interface;
-
    ------------------------------
    -- In_Unconditional_Context --
    ------------------------------
@@ -2747,10 +2686,16 @@ package body Exp_Util is
                N_Package_Specification                  |
                N_Parameter_Association                  |
                N_Parameter_Specification                |
+               N_Pop_Constraint_Error_Label             |
+               N_Pop_Program_Error_Label                |
+               N_Pop_Storage_Error_Label                |
                N_Pragma_Argument_Association            |
                N_Procedure_Specification                |
                N_Protected_Body                         |
                N_Protected_Definition                   |
+               N_Push_Constraint_Error_Label            |
+               N_Push_Program_Error_Label               |
+               N_Push_Storage_Error_Label               |
                N_Qualified_Expression                   |
                N_Range                                  |
                N_Range_Constraint                       |
@@ -4485,7 +4430,7 @@ package body Exp_Util is
       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
         and then not Safe_Unchecked_Type_Conversion (Exp)
       then
-         if Controlled_Type (Exp_Type) then
+         if CW_Or_Controlled_Type (Exp_Type) then
 
             --  Use a renaming to capture the expression, rather than create
             --  a controlled temporary.
@@ -5124,20 +5069,15 @@ package body Exp_Util is
             E : Entity_Id;
 
          begin
-            E := First_Entity (Typ);
+            E := First_Component_Or_Discriminant (Typ);
             while Present (E) loop
-               if Ekind (E) = E_Component
-                 or else Ekind (E) = E_Discriminant
+               if Component_May_Be_Bit_Aligned (E)
+                 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
                then
-                  if Component_May_Be_Bit_Aligned (E)
-                    or else
-                      Type_May_Have_Bit_Aligned_Components (Etype (E))
-                  then
-                     return True;
-                  end if;
+                  return True;
                end if;
 
-               Next_Entity (E);
+               Next_Component_Or_Discriminant (E);
             end loop;
 
             return False;