exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the run-time…

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

gcc/ada/exp_atag.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             E X P _ A T A G                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2006, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
+-- Boston, MA 02110-1301, USA.                                              --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains routines involved in the frontend expansion of
+--  subprograms of package Ada.Tags
+
+with Types; use Types;
+
+package Exp_Atag is
+
+   function Build_CW_Membership
+     (Loc          : Source_Ptr;
+      Obj_Tag_Node : Node_Id;
+      Typ_Tag_Node : Node_Id) return Node_Id;
+   --  Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each
+   --  dispatch table contains a reference to a table of ancestors (stored
+   --  in the first part of the Tags_Table) and a count of the level of
+   --  inheritance "Idepth". Obj is in Typ'Class if Typ'Tag is in the table
+   --  of ancestors that are contained in the dispatch table referenced by
+   --  Obj'Tag. Knowing the level of inheritance of both types, this can be
+   --  computed in constant time by the formula:
+   --
+   --   TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
+   --     = Typ'tag
+
+   function Build_Get_Access_Level
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id;
+   --  Build code that retrieves the accessibility level of the tagged type.
+   --
+   --  Generates: TSD (Tag).Access_Level
+
+   function Build_Get_Predefined_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id) return Node_Id;
+   --  Given a pointer to a dispatch table (T) and a position in the DT, build
+   --  code that gets the address of the predefined virtual function stored in
+   --  it (used for dispatching calls).
+   --
+   --  Generates: Predefined_DT (Tag).D (Position);
+
+   function Build_Get_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id) return Node_Id;
+   --  Build code that retrieves the address of the virtual function stored in
+   --  a given position of the dispatch table (used for dispatching calls).
+   --
+   --  Generates: To_Tag (Tag).D (Position);
+
+   function Build_Get_RC_Offset
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id) return Node_Id;
+   --  Build code that retrieves the Offset of the implicit record controller
+   --  when the object has controlled components. O otherwise.
+   --
+   --  Generates: TSD (T).RC_Offset;
+
+   function Build_Get_Remotely_Callable
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id) return Node_Id;
+   --  Build code that retrieves the value previously saved by Set_Remotely
+   --  Callable
+   --
+   --  Generates: TSD (Tag).Remotely_Callable
+
+   function Build_Inherit_Predefined_Prims
+     (Loc              : Source_Ptr;
+      Old_Tag_Node     : Node_Id;
+      New_Tag_Node     : Node_Id) return Node_Id;
+   --  Build code that inherits the predefined primitives of the parent.
+   --
+   --  Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
+   --               Predefined_DT (Old_T).D (All_Predefined_Prims);
+
+   function Build_Inherit_Prims
+     (Loc          : Source_Ptr;
+      Old_Tag_Node : Node_Id;
+      New_Tag_Node : Node_Id;
+      Num_Prims    : Nat) return Node_Id;
+   --  Build code that inherits Num_Prims user-defined primitives from the
+   --  dispatch table of the parent type.
+   --
+   --  Generates:
+   --    New_Tag.Prims_Ptr (1 .. Num_Prims) :=
+   --      Old_Tag.Prims_Ptr (1 .. Num_Prims);
+
+   function Build_Inherit_TSD
+     (Loc               : Source_Ptr;
+      Old_Tag_Node      : Node_Id;
+      New_Tag_Node      : Node_Id;
+      I_Depth           : Nat;
+      Parent_Num_Ifaces : Nat) return Node_Id;
+   --  Generates code that initializes the TSD of a type knowing the tag,
+   --  inheritance depth, and number of interface types of the parent type.
+   --
+   --  Generates:
+   --     --  Copy the table of ancestors of the parent
+   --
+   --     TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
+   --       TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);
+   --
+   --     --  Copy the table of interfaces of the parent
+   --
+   --     if TSD (Old_Tag).Ifaces_Table_Ptr /= null then
+   --        New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
+   --          Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
+   --     end if;
+   --
+   --     TSD (New_Tag).Tags_Table (0) := New_Tag;
+
+   function Build_New_TSD
+     (Loc          : Source_Ptr;
+      New_Tag_Node : Node_Id) return List_Id;
+   --  Build code that initializes the TSD of a root type.
+   --  Generates: TSD (New_Tag).Tags_Table (0) := New_Tag;
+
+   function Build_Set_External_Tag
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id;
+      Value_Node : Node_Id) return Node_Id;
+   --  Build code that saves the address of the string containing the external
+   --  tag in the dispatch table.
+   --
+   --  Generates: TSD (Tag).External_Tag := Cstring_Ptr! (Value);
+
+   function Build_Set_Predefined_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id;
+      Address_Node  : Node_Id) return Node_Id;
+   --  Build code that saves the address of a virtual function in a given
+   --  Position of the portion of the dispatch table associated with the
+   --  predefined primitives of Tag (used for overriding).
+   --
+   --  Generates: Predefined_DT (Tag).D (Position) := Value
+
+   function Build_Set_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id;
+      Address_Node  : Node_Id) return Node_Id;
+   --  Build code that saves the address of a virtual function in a given
+   --  Position of the dispatch table associated with the Tag (used for
+   --  overriding).
+   --
+   --  Generates: Tag.D (Position) := Value
+
+   function Build_Set_TSD
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id;
+      Value_Node : Node_Id) return Node_Id;
+   --  Build code that saves the address of the record containing the Type
+   --  Specific Data generated by GNAT.
+   --
+   --  Generates: To_Addr_Ptr (To_Address (Tag) - K_Typeinfo).all := Value
+
+end Exp_Atag;

gcc/ada/exp_ch13.adb

@@ -27,6 +27,7 @@
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
+with Exp_Atag; use Exp_Atag;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Imgv; use Exp_Imgv;
@@ -211,16 +212,16 @@ package body Exp_Ch13 is
             Make_String_Literal (Loc, Strval => New_Val)));
 
       Append_Freeze_Actions (Ent, New_List (
-        Make_Procedure_Call_Statement (Loc,
-          Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
-          Parameter_Associations => New_List (
+
+        Build_Set_External_Tag (Loc,
+          Tag_Node =>
             Make_Attribute_Reference (Loc,
               Attribute_Name => Name_Tag,
               Prefix         => New_Occurrence_Of (Ent, Loc)),
-
+          Value_Node =>
             Make_Attribute_Reference (Loc,
               Attribute_Name => Name_Address,
-              Prefix         => New_Occurrence_Of (E, Loc)))),
+              Prefix         => New_Occurrence_Of (E, Loc))),
 
         Make_Procedure_Call_Statement (Loc,
           Name => New_Reference_To (RTE (RE_Register_Tag), Loc),

gcc/ada/exp_disp.ads

@@ -168,46 +168,24 @@ package Exp_Disp is
    --    Exp_Disp.Set_All_DT_Position      - direct   use
 
    type DT_Access_Action is
-      (CW_Membership,
-       IW_Membership,
-       DT_Entry_Size,
-       DT_Prologue_Size,
-       Get_Access_Level,
+      (IW_Membership,
        Get_Entry_Index,
-       Get_External_Tag,
-       Get_Predefined_Prim_Op_Address,
-       Get_Prim_Op_Address,
        Get_Prim_Op_Kind,
-       Get_RC_Offset,
-       Get_Remotely_Callable,
        Get_Tagged_Kind,
-       Inherit_DT,
-       Inherit_TSD,
        Register_Interface_Tag,
        Register_Tag,
-       Set_Access_Level,
        Set_Entry_Index,
-       Set_Expanded_Name,
-       Set_External_Tag,
-       Set_Interface_Table,
        Set_Offset_Index,
        Set_OSD,
-       Set_Predefined_Prim_Op_Address,
-       Set_Prim_Op_Address,
        Set_Prim_Op_Kind,
-       Set_RC_Offset,
-       Set_Remotely_Callable,
        Set_Signature,
        Set_SSD,
-       Set_TSD,
-       Set_Tagged_Kind,
-       TSD_Entry_Size,
-       TSD_Prologue_Size);
+       Set_Tagged_Kind);
 
    procedure Expand_Dispatching_Call (Call_Node : Node_Id);
    --  Expand the call to the operation through the dispatch table and perform
-   --  the required tag checks when appropriate. For CPP types the call is
-   --  done through the Vtable (tag checks are not relevant)
+   --  the required tag checks when appropriate. For CPP types tag checks are
+   --  not relevant.
 
    procedure Expand_Interface_Actuals (Call_Node : Node_Id);
    --  Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
@@ -245,15 +223,6 @@ package Exp_Disp is
    --  the secondary dispatch table of Prim's controlling type with Thunk_Id's
    --  address.
 
-   function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
-   --  Return an expression that holds True if the object can be transmitted
-   --  onto another partition according to E.4 (18)
-
-   function Init_Predefined_Interface_Primitives
-     (Typ : Entity_Id) return List_Id;
-   --  Ada 2005 (AI-251): Initialize the entries associated with predefined
-   --  primitives in all the secondary dispatch tables of Typ.
-
    function Make_DT_Access_Action
      (Typ    : Entity_Id;
       Action : DT_Access_Action;
@@ -333,7 +302,7 @@ package Exp_Disp is
    procedure Make_Secondary_DT
      (Typ             : Entity_Id;
       Ancestor_Typ    : Entity_Id;
-      Suffix_Index    : Int;
+      Suffix_Index    : Nat;
       Iface           : Entity_Id;
       AI_Tag          : Entity_Id;
       Acc_Disp_Tables : in out Elist_Id;

gcc/ada/exp_util.ads

@@ -33,21 +33,6 @@ 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 --
    -----------------------------------------------
@@ -363,16 +348,6 @@ package Exp_Util is
    --  Ada 2005 (AI-251): Given a type T implementing the interface Iface,
    --  return the record component containing the tag of Iface.
 
-   function Find_Implemented_Interface
-     (Typ          : Entity_Id;
-      Kind         : Interface_Kind;
-      Check_Parent : Boolean := False) return Entity_Id;
-   --  Ada 2005 (AI-345): Find a designated kind of interface implemented by
-   --  Typ or any parent subtype. Return the first encountered interface that
-   --  correspond to the selected class. Return Empty if no such interface is
-   --  found. Use Check_Parent to climb a potential derivation chain and
-   --  examine the parent subtypes for any implementation.
-
    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
    --  Find the first primitive operation of type T whose name is 'Name'.
    --  This function allows the use of a primitive operation which is not
@@ -444,14 +419,6 @@ 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_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/par-ch12.adb

@@ -635,8 +635,7 @@ package body Ch12 is
             return P_Formal_Floating_Point_Definition;
 
          when Tok_Interface => --  Ada 2005 (AI-251)
-            return P_Interface_Type_Definition (Abstract_Present => False,
-                                                Is_Synchronized => False);
+            return P_Interface_Type_Definition (Abstract_Present => False);
 
          when Tok_Left_Paren =>
             return P_Formal_Discrete_Type_Definition;
@@ -646,9 +645,8 @@ package body Ch12 is
             Scan; --  past LIMITED
 
             if Token = Tok_Interface then
-               Typedef_Node := P_Interface_Type_Definition
-                                (Abstract_Present => False,
-                                 Is_Synchronized  => False);
+               Typedef_Node :=
+                 P_Interface_Type_Definition (Abstract_Present => False);
                Set_Limited_Present (Typedef_Node);
                return Typedef_Node;
 
@@ -720,9 +718,8 @@ package body Ch12 is
                --  Interface
 
                else
-                  Typedef_Node := P_Interface_Type_Definition
-                                    (Abstract_Present => False,
-                                     Is_Synchronized  => True);
+                  Typedef_Node :=
+                    P_Interface_Type_Definition (Abstract_Present => False);
 
                   case Saved_Token is
                      when Tok_Task =>

gcc/ada/sem_disp.adb

@@ -204,6 +204,12 @@ package body Sem_Disp is
                Tagged_Type := Base_Type (Designated_Type (T));
             end if;
 
+         --  Ada 2005 : an incomplete type can be tagged. An operation with
+         --  an access parameter of the type is dispatching.
+
+         elsif Scope (Designated_Type (T)) = Current_Scope then
+            Tagged_Type := Designated_Type (T);
+
          --  Ada 2005 (AI-50217)
 
          elsif From_With_Type (Designated_Type (T))
@@ -231,13 +237,13 @@ package body Sem_Disp is
                and then (not Is_Generic_Type (Tagged_Type)
                           or else not Comes_From_Source (Subp)))
         or else
-          (Is_Formal_Subprogram (Subp) and then Is_Abstract (Subp))
+          (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
         or else
           (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
             and then
               Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
             and then
-              Is_Abstract (Subp))
+              Is_Abstract_Subprogram (Subp))
       then
          return Tagged_Type;
 
@@ -274,11 +280,11 @@ package body Sem_Disp is
          Par  : Node_Id;
 
       begin
-         if Is_Abstract (Subp)
+         if Is_Abstract_Subprogram (Subp)
            and then No (Controlling_Argument (N))
          then
             if Present (Alias (Subp))
-              and then not Is_Abstract (Alias (Subp))
+              and then not Is_Abstract_Subprogram (Alias (Subp))
               and then No (DTC_Entity (Subp))
             then
                --  Private overriding of inherited abstract operation,
@@ -428,6 +434,7 @@ package body Sem_Disp is
             --  Mark call as a dispatching call
 
             Set_Controlling_Argument (N, Control);
+            Check_Restriction (No_Dispatching_Calls, N);
 
             --  Ada 2005 (AI-318-02): Check current implementation restriction
             --  that a dispatching call cannot be made to a primitive function
@@ -481,7 +488,7 @@ package body Sem_Disp is
                            (Expression (Original_Node (Actual)))));
                   end if;
 
-                  if Present (Func) and then Is_Abstract (Func) then
+                  if Present (Func) and then Is_Abstract_Subprogram (Func) then
                      Error_Msg_N (
                        "call to abstract function must be dispatching", N);
                   end if;
@@ -1080,7 +1087,8 @@ package body Sem_Disp is
                --  a descendant type and inherits a nonabstract version.
 
                if Etype (Subp) /= Tagged_Type then
-                  Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
+                  Set_Is_Abstract_Subprogram
+                    (Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
                end if;
             end if;
          end if;
@@ -1315,7 +1323,8 @@ package body Sem_Disp is
       then
          --  Ada 2005 (AI-251): Update the attribute alias of all the aliased
          --  entities of the overriden primitive to reference New_Op, and also
-         --  propagate them the new value of the attribute Is_Abstract.
+         --  propagate them the new value of the attribute
+         --  Is_Abstract_Subprogram.
 
          Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
          while Present (Elmt) loop
@@ -1328,12 +1337,13 @@ package body Sem_Disp is
               and then Alias (Prim) = Prev_Op
             then
                Set_Alias (Prim, New_Op);
-               Set_Is_Abstract (Prim, Is_Abstract (New_Op));
+               Set_Is_Abstract_Subprogram
+                 (Prim, Is_Abstract_Subprogram (New_Op));
 
                --  Ensure that this entity will be expanded to fill the
                --  corresponding entry in its dispatch table.
 
-               if not Is_Abstract (Prim) then
+               if not Is_Abstract_Subprogram (Prim) then
                   Set_Has_Delayed_Freeze (Prim);
                end if;
             end if;

gcc/ada/sem_elab.adb

@@ -2443,15 +2443,13 @@ package body Sem_Elab is
                      Chars (Subp) = Name_Initialize
                        and then Comes_From_Source (Subp)
                        and then Present (Parameter_Associations (Call))
-                       and then Is_Controlled
-                         (Etype (First (Parameter_Associations (Call))));
+                       and then Is_Controlled (Etype (First_Actual (Call)));
    begin
       --  If the unit is mentioned in a with_clause of the current
       --  unit, it is visible, and we can set the elaboration flag.
 
       if Is_Immediately_Visible (Scop)
-        or else
-          (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
+        or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
       then
          Activate_Elaborate_All_Desirable (Call, Scop);
          Set_Suppress_Elaboration_Warnings (Scop, True);
@@ -2482,10 +2480,10 @@ package body Sem_Elab is
       if Is_Init_Proc (Subp)
         or else Init_Call
       then
-         --  The initialization call is on an object whose type is not
-         --  declared in the same scope as the subprogram. The type of
-         --  the object must be a subtype of the type of operation. This
-         --  object is the first actual in the call.
+         --  The initialization call is on an object whose type is not declared
+         --  in the same scope as the subprogram. The type of the object must
+         --  be a subtype of the type of operation. This object is the first
+         --  actual in the call.
 
          declare
             Typ : constant Entity_Id :=