sem_util.ads, [...] (May_Be_Lvalue): A prefix of an attribute reference acts as an lvalue when...

2007-04-20  Hristian Kirtchev  <kirtchev@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_util.ads, sem_util.adb (May_Be_Lvalue): A prefix of an attribute
	reference acts as an lvalue when the attribute name modifies the prefix
	(Is_Coextension_Root): New routine.
	(Mark_Static_Coextensions): New routine.
	(Type_Access_Level): Revise code for checking the level of the
	anonymous access type of a return object.
	(Safe_To_Capture_Value): Not safe to capture if Address_Taken
	(Matches_Prefixed_View_Profile): Remove the no longer necessary
	retrieval of the corresponding controlling record type.
	(Find_Overridden_Synchronized_Primitive): Code cleanup. Add handling of
	concurrent types declared within a generic as well as class wide types.
	Emit a mode incompatibility error whenever a protected entry or routine
	override an interface routine whose first parameter is not of mode
	"out", "in out" or access to variable.
	(Overrides_Synchronized_Primitive): Rename to
	Find_Overridden_Synchronized_Primitive.
	(Collect_Interface_Components): New subprogram that collects all the
	components of a tagged record containing tags of secondary dispatch
	tables.
	(Add_Global_Declaration): New procedure
	(Abstract_Interface_List): Handle properly the case of a subtype of a
	private extension.
	(Type_Access_Level): In the case of a type whose parent scope is a
	return statement, call Type_Access_Level recursively on the enclosing
	function's result type to determine the level of the return object's
	type.
	(Build_Elaboration_Entity): Build name of elaboration entity from the
	scope chain of the entity, rather than the unit name of the file name.
	(Check_Nested_Access): New procedure.
	(Has_Up_Level_Access, Set_Has_Up_Level_Access): New procedures.
	(Find_Direct_Name, Note_Possible_Modification): Use Check_Nested_Access.
	(Get_Renamed_Entity): Utility routine for performing common operation
	of chasing the Renamed_Entity field of an entity.

From-SVN: r125453

gcc/ada/sem_util.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -36,7 +36,6 @@ with Fname;    use Fname;
 with Freeze;   use Freeze;
 with Lib;      use Lib;
 with Lib.Xref; use Lib.Xref;
-with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Output;   use Output;
@@ -45,6 +44,7 @@ with Rtsfind;  use Rtsfind;
 with Scans;    use Scans;
 with Scn;      use Scn;
 with Sem;      use Sem;
+with Sem_Attr; use Sem_Attr;
 with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Eval; use Sem_Eval;
@@ -126,6 +126,12 @@ package body Sem_Util is
       elsif Ekind (Typ) = E_Record_Subtype then
          Nod := Type_Definition (Parent (Etype (Typ)));
 
+      elsif Ekind (Typ) = E_Record_Subtype_With_Private then
+
+         --  Recurse, because parent may still be a private extension
+
+         return Abstract_Interface_List (Etype (Full_View (Typ)));
+
       else pragma Assert ((Ekind (Typ)) = E_Record_Type);
          if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
             Nod := Formal_Type_Definition (Parent (Typ));
@@ -156,6 +162,22 @@ package body Sem_Util is
       Append_Elmt (A, L);
    end Add_Access_Type_To_Process;
 
+   ----------------------------
+   -- Add_Global_Declaration --
+   ----------------------------
+
+   procedure Add_Global_Declaration (N : Node_Id) is
+      Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
+
+   begin
+      if No (Declarations (Aux_Node)) then
+         Set_Declarations (Aux_Node, New_List);
+      end if;
+
+      Append_To (Declarations (Aux_Node), N);
+      Analyze (N);
+   end Add_Global_Declaration;
+
    -----------------------
    -- Alignment_In_Bits --
    -----------------------
@@ -719,11 +741,39 @@ package body Sem_Util is
    ------------------------------
 
    procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
-      Loc       : constant Source_Ptr       := Sloc (N);
-      Unum      : constant Unit_Number_Type := Get_Source_Unit (Loc);
-      Decl      : Node_Id;
-      P         : Natural;
-      Elab_Ent  : Entity_Id;
+      Loc      : constant Source_Ptr := Sloc (N);
+      Decl     : Node_Id;
+      Elab_Ent : Entity_Id;
+
+      procedure Set_Package_Name (Ent : Entity_Id);
+      --  Given an entity, sets the fully qualified name of the entity in
+      --  Name_Buffer, with components separated by double underscores. This
+      --  is a recursive routine that climbs the scope chain to Standard.
+
+      ----------------------
+      -- Set_Package_Name --
+      ----------------------
+
+      procedure Set_Package_Name (Ent : Entity_Id) is
+      begin
+         if Scope (Ent) /= Standard_Standard then
+            Set_Package_Name (Scope (Ent));
+
+            declare
+               Nam : constant String := Get_Name_String (Chars (Ent));
+            begin
+               Name_Buffer (Name_Len + 1) := '_';
+               Name_Buffer (Name_Len + 2) := '_';
+               Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
+               Name_Len := Name_Len + Nam'Length + 2;
+            end;
+
+         else
+            Get_Name_String (Chars (Ent));
+         end if;
+      end Set_Package_Name;
+
+   --  Start of processing for Build_Elaboration_Entity
 
    begin
       --  Ignore if already constructed
@@ -732,33 +782,18 @@ package body Sem_Util is
          return;
       end if;
 
-      --  Construct name of elaboration entity as xxx_E, where xxx
-      --  is the unit name with dots replaced by double underscore.
-      --  We have to manually construct this name, since it will
-      --  be elaborated in the outer scope, and thus will not have
-      --  the unit name automatically prepended.
-
-      Get_Name_String (Unit_Name (Unum));
+      --  Construct name of elaboration entity as xxx_E, where xxx is the unit
+      --  name with dots replaced by double underscore. We have to manually
+      --  construct this name, since it will be elaborated in the outer scope,
+      --  and thus will not have the unit name automatically prepended.
 
-      --  Replace the %s by _E
+      Set_Package_Name (Spec_Id);
 
-      Name_Buffer (Name_Len - 1 .. Name_Len) := "_E";
+      --  Append _E
 
-      --  Replace dots by double underscore
-
-      P := 2;
-      while P < Name_Len - 2 loop
-         if Name_Buffer (P) = '.' then
-            Name_Buffer (P + 2 .. Name_Len + 1) :=
-              Name_Buffer (P + 1 .. Name_Len);
-            Name_Len := Name_Len + 1;
-            Name_Buffer (P) := '_';
-            Name_Buffer (P + 1) := '_';
-            P := P + 3;
-         else
-            P := P + 1;
-         end if;
-      end loop;
+      Name_Buffer (Name_Len + 1) := '_';
+      Name_Buffer (Name_Len + 2) := 'E';
+      Name_Len := Name_Len + 2;
 
       --  Create elaboration flag
 
@@ -766,10 +801,6 @@ package body Sem_Util is
         Make_Defining_Identifier (Loc, Chars => Name_Find);
       Set_Elaboration_Entity (Spec_Id, Elab_Ent);
 
-      if No (Declarations (Aux_Decls_Node (N))) then
-         Set_Declarations (Aux_Decls_Node (N), New_List);
-      end if;
-
       Decl :=
          Make_Object_Declaration (Loc,
            Defining_Identifier => Elab_Ent,
@@ -778,8 +809,9 @@ package body Sem_Util is
            Expression          =>
              New_Occurrence_Of (Standard_False, Loc));
 
-      Append_To (Declarations (Aux_Decls_Node (N)), Decl);
-      Analyze (Decl);
+      Push_Scope (Standard_Standard);
+      Add_Global_Declaration (Decl);
+      Pop_Scope;
 
       --  Reset True_Constant indication, since we will indeed assign a value
       --  to the variable in the binder main. We also kill the Current_Value
@@ -965,13 +997,48 @@ package body Sem_Util is
       end if;
    end Check_Fully_Declared;
 
+   -------------------------
+   -- Check_Nested_Access --
+   -------------------------
+
+   procedure Check_Nested_Access (Ent : Entity_Id) is
+      Scop         : constant Entity_Id := Current_Scope;
+      Current_Subp : Entity_Id;
+
+   begin
+      --  Currently only enabled for VM back-ends for efficiency, should we
+      --  enable it more systematically ???
+
+      if VM_Target /= No_VM
+        and then (Ekind (Ent) = E_Variable
+                    or else
+                  Ekind (Ent) = E_Constant
+                    or else
+                  Ekind (Ent) = E_Loop_Parameter)
+        and then Scope (Ent) /= Empty
+        and then not Is_Library_Level_Entity (Ent)
+      then
+         if Is_Subprogram (Scop)
+           or else Is_Generic_Subprogram (Scop)
+           or else Is_Entry (Scop)
+         then
+            Current_Subp := Scop;
+         else
+            Current_Subp := Current_Subprogram;
+         end if;
+
+         if Enclosing_Subprogram (Ent) /= Current_Subp then
+            Set_Has_Up_Level_Access (Ent, True);
+         end if;
+      end if;
+   end Check_Nested_Access;
+
    ------------------------------------------
    -- Check_Potentially_Blocking_Operation --
    ------------------------------------------
 
    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
-      S   : Entity_Id;
-
+      S : Entity_Id;
    begin
       --  N is one of the potentially blocking operations listed in 9.5.1(8).
       --  When pragma Detect_Blocking is active, the run time will raise
@@ -1178,6 +1245,65 @@ package body Sem_Util is
    end Collect_Abstract_Interfaces;
 
    ----------------------------------
+   -- Collect_Interface_Components --
+   ----------------------------------
+
+   procedure Collect_Interface_Components
+     (Tagged_Type     : Entity_Id;
+      Components_List : out Elist_Id)
+   is
+      procedure Collect (Typ : Entity_Id);
+      --  Subsidiary subprogram used to climb to the parents
+
+      -------------
+      -- Collect --
+      -------------
+
+      procedure Collect (Typ : Entity_Id) is
+         Tag_Comp : Entity_Id;
+
+      begin
+         if Etype (Typ) /= Typ
+
+            --  Protect the frontend against wrong sources. For example:
+
+            --    package P is
+            --      type A is tagged null record;
+            --      type B is new A with private;
+            --      type C is new A with private;
+            --    private
+            --      type B is new C with null record;
+            --      type C is new B with null record;
+            --    end P;
+
+           and then Etype (Typ) /= Tagged_Type
+         then
+            Collect (Etype (Typ));
+         end if;
+
+         --  Collect the components containing tags of secondary dispatch
+         --  tables.
+
+         Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
+         while Present (Tag_Comp) loop
+            pragma Assert (Present (Related_Interface (Tag_Comp)));
+            Append_Elmt (Tag_Comp, Components_List);
+
+            Tag_Comp := Next_Tag_Component (Tag_Comp);
+         end loop;
+      end Collect;
+
+   --  Start of processing for Collect_Interface_Components
+
+   begin
+      pragma Assert (Ekind (Tagged_Type) = E_Record_Type
+        and then Is_Tagged_Type (Tagged_Type));
+
+      Components_List := New_Elmt_List;
+      Collect (Tagged_Type);
+   end Collect_Interface_Components;
+
+   ----------------------------------
    -- Collect_Primitive_Operations --
    ----------------------------------
 
@@ -2415,6 +2541,321 @@ package body Sem_Util is
       raise Program_Error;
    end Find_Corresponding_Discriminant;
 
+   --------------------------------------------
+   -- Find_Overridden_Synchronized_Primitive --
+   --------------------------------------------
+
+   function Find_Overridden_Synchronized_Primitive
+     (Def_Id      : Entity_Id;
+      First_Hom   : Entity_Id;
+      Ifaces_List : Elist_Id;
+      In_Scope    : Boolean := True) return Entity_Id
+   is
+      Candidate : Entity_Id := Empty;
+      Hom       : Entity_Id := Empty;
+      Iface_Typ : Entity_Id;
+      Subp      : Entity_Id := Empty;
+      Tag_Typ   : Entity_Id;
+
+      function Find_Parameter_Type (Param : Node_Id) return Entity_Id;
+      --  Return the type of a formal parameter as determined by its
+      --  specification.
+
+      function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean;
+      --  For an overridden subprogram Subp, check whether the mode of its
+      --  first parameter is correct depending on the kind of Tag_Typ.
+
+      function Matches_Prefixed_View_Profile
+        (Prim_Params  : List_Id;
+         Iface_Params : List_Id) return Boolean;
+      --  Determine whether a subprogram's parameter profile Prim_Params
+      --  matches that of a potentially overriden interface subprogram
+      --  Iface_Params. Also determine if the type of first parameter of
+      --  Iface_Params is an implemented interface.
+
+      -------------------------
+      -- Find_Parameter_Type --
+      -------------------------
+
+      function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
+      begin
+         pragma Assert (Nkind (Param) = N_Parameter_Specification);
+
+         if Nkind (Parameter_Type (Param)) = N_Access_Definition then
+            return Etype (Subtype_Mark (Parameter_Type (Param)));
+
+         else
+            return Etype (Parameter_Type (Param));
+         end if;
+      end Find_Parameter_Type;
+
+      -----------------------------
+      -- Has_Correct_Formal_Mode --
+      -----------------------------
+
+      function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean is
+         Param : Node_Id;
+
+      begin
+         Param := First_Formal (Subp);
+
+         --  In order for an entry or a protected procedure to override, the
+         --  first parameter of the overridden routine must be of mode "out",
+         --  "in out" or access-to-variable.
+
+         if (Ekind (Subp) = E_Entry
+               or else Ekind (Subp) = E_Procedure)
+           and then Is_Protected_Type (Tag_Typ)
+           and then Ekind (Param) /= E_In_Out_Parameter
+           and then Ekind (Param) /= E_Out_Parameter
+           and then Nkind (Parameter_Type (Parent (Param))) /=
+                      N_Access_Definition
+         then
+            return False;
+         end if;
+
+         --  All other cases are OK since a task entry or routine does not
+         --  have a restriction on the mode of the first parameter of the
+         --  overridden interface routine.
+
+         return True;
+      end Has_Correct_Formal_Mode;
+
+      -----------------------------------
+      -- Matches_Prefixed_View_Profile --
+      -----------------------------------
+
+      function Matches_Prefixed_View_Profile
+        (Prim_Params  : List_Id;
+         Iface_Params : List_Id) return Boolean
+      is
+         Iface_Id     : Entity_Id;
+         Iface_Param  : Node_Id;
+         Iface_Typ    : Entity_Id;
+         Prim_Id      : Entity_Id;
+         Prim_Param   : Node_Id;
+         Prim_Typ     : Entity_Id;
+
+         function Is_Implemented (Iface : Entity_Id) return Boolean;
+         --  Determine if Iface is implemented by the current task or
+         --  protected type.
+
+         --------------------
+         -- Is_Implemented --
+         --------------------
+
+         function Is_Implemented (Iface : Entity_Id) return Boolean is
+            Iface_Elmt : Elmt_Id;
+
+         begin
+            Iface_Elmt := First_Elmt (Ifaces_List);
+            while Present (Iface_Elmt) loop
+               if Node (Iface_Elmt) = Iface then
+                  return True;
+               end if;
+
+               Next_Elmt (Iface_Elmt);
+            end loop;
+
+            return False;
+         end Is_Implemented;
+
+      --  Start of processing for Matches_Prefixed_View_Profile
+
+      begin
+         Iface_Param := First (Iface_Params);
+         Iface_Typ   := Find_Parameter_Type (Iface_Param);
+         Prim_Param  := First (Prim_Params);
+
+         --  The first parameter of the potentially overriden subprogram
+         --  must be an interface implemented by Prim.
+
+         if not Is_Interface (Iface_Typ)
+           or else not Is_Implemented (Iface_Typ)
+         then
+            return False;
+         end if;
+
+         --  The checks on the object parameters are done, move onto the rest
+         --  of the parameters.
+
+         if not In_Scope then
+            Prim_Param := Next (Prim_Param);
+         end if;
+
+         Iface_Param := Next (Iface_Param);
+         while Present (Iface_Param) and then Present (Prim_Param) loop
+            Iface_Id  := Defining_Identifier (Iface_Param);
+            Iface_Typ := Find_Parameter_Type (Iface_Param);
+            Prim_Id   := Defining_Identifier (Prim_Param);
+            Prim_Typ  := Find_Parameter_Type (Prim_Param);
+
+            --  Case of multiple interface types inside a parameter profile
+
+            --     (Obj_Param : in out Iface; ...; Param : Iface)
+
+            --  If the interface type is implemented, then the matching type
+            --  in the primitive should be the implementing record type.
+
+            if Ekind (Iface_Typ) = E_Record_Type
+              and then Is_Interface (Iface_Typ)
+              and then Is_Implemented (Iface_Typ)
+            then
+               if Prim_Typ /= Tag_Typ then
+                  return False;
+               end if;
+
+            --  The two parameters must be both mode and subtype conformant
+
+            elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
+              or else
+                not Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
+            then
+               return False;
+            end if;
+
+            Next (Iface_Param);
+            Next (Prim_Param);
+         end loop;
+
+         --  One of the two lists contains more parameters than the other
+
+         if Present (Iface_Param) or else Present (Prim_Param) then
+            return False;
+         end if;
+
+         return True;
+      end Matches_Prefixed_View_Profile;
+
+   --  Start of processing for Find_Overridden_Synchronized_Primitive
+
+   begin
+      --  At this point the caller should have collected the interfaces
+      --  implemented by the synchronized type.
+
+      pragma Assert (Present (Ifaces_List));
+
+      --  Find the tagged type to which subprogram Def_Id is primitive. If the
+      --  subprogram was declared within a protected or a task type, the type
+      --  is the scope itself, otherwise it is the type of the first parameter.
+
+      if In_Scope then
+         Tag_Typ := Scope (Def_Id);
+
+      elsif Present (First_Formal (Def_Id)) then
+         Tag_Typ := Find_Parameter_Type (Parent (First_Formal (Def_Id)));
+
+      --  A parameterless subprogram which is declared outside a synchronized
+      --  type cannot act as a primitive, thus it cannot override anything.
+
+      else
+         return Empty;
+      end if;
+
+      --  Traverse the homonym chain, looking at a potentially overriden
+      --  subprogram that belongs to an implemented interface.
+
+      Hom := First_Hom;
+      while Present (Hom) loop
+         Subp := Hom;
+
+         --  Entries can override abstract or null interface procedures
+
+         if Ekind (Def_Id) = E_Entry
+           and then Ekind (Subp) = E_Procedure
+           and then Nkind (Parent (Subp)) = N_Procedure_Specification
+           and then (Is_Abstract_Subprogram (Subp)
+                       or else Null_Present (Parent (Subp)))
+         then
+            while Present (Alias (Subp)) loop
+               Subp := Alias (Subp);
+            end loop;
+
+            if Matches_Prefixed_View_Profile
+                 (Parameter_Specifications (Parent (Def_Id)),
+                  Parameter_Specifications (Parent (Subp)))
+            then
+               Candidate := Subp;
+
+               --  Absolute match
+
+               if Has_Correct_Formal_Mode (Candidate) then
+                  return Candidate;
+               end if;
+            end if;
+
+         --  Procedures can override abstract or null interface procedures
+
+         elsif Ekind (Def_Id) = E_Procedure
+           and then Ekind (Subp) = E_Procedure
+           and then Nkind (Parent (Subp)) = N_Procedure_Specification
+           and then (Is_Abstract_Subprogram (Subp)
+                       or else Null_Present (Parent (Subp)))
+           and then Matches_Prefixed_View_Profile
+                      (Parameter_Specifications (Parent (Def_Id)),
+                       Parameter_Specifications (Parent (Subp)))
+         then
+            Candidate := Subp;
+
+            --  Absolute match
+
+            if Has_Correct_Formal_Mode (Candidate) then
+               return Candidate;
+            end if;
+
+         --  Functions can override abstract interface functions
+
+         elsif Ekind (Def_Id) = E_Function
+           and then Ekind (Subp) = E_Function
+           and then Nkind (Parent (Subp)) = N_Function_Specification
+           and then Is_Abstract_Subprogram (Subp)
+           and then Matches_Prefixed_View_Profile
+                      (Parameter_Specifications (Parent (Def_Id)),
+                       Parameter_Specifications (Parent (Subp)))
+           and then Etype (Result_Definition (Parent (Def_Id))) =
+                    Etype (Result_Definition (Parent (Subp)))
+         then
+            return Subp;
+         end if;
+
+         Hom := Homonym (Hom);
+      end loop;
+
+      --  After examining all candidates for overriding, we are left with
+      --  the best match which is a mode incompatible interface routine.
+      --  Do not emit an error of the Expander is active since this error
+      --  will be detected later on after all concurrent types are expanded
+      --  and all wrappers are built. This check is meant for spec-only
+      --  compilations.
+
+      if Present (Candidate)
+        and then not Expander_Active
+      then
+         Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate)));
+
+         --  Def_Id is primitive of a protected type, the candidate is
+         --  primitive of a limited or synchronized interface.
+
+         if Is_Protected_Type (Tag_Typ)
+           and then
+             (Is_Limited_Interface (Iface_Typ)
+                or else Is_Protected_Interface (Iface_Typ)
+                or else Is_Synchronized_Interface (Iface_Typ)
+                or else Is_Task_Interface (Iface_Typ))
+         then
+            Error_Msg_NE
+              ("first formal of & must be of mode `OUT`, `IN OUT` or " &
+               "access-to-variable", Tag_Typ, Candidate);
+
+            Error_Msg_N
+              ("\to be overridden by protected procedure or entry " &
+               "(`R`M 9.4(11))", Tag_Typ);
+         end if;
+      end if;
+
+      return Candidate;
+   end Find_Overridden_Synchronized_Primitive;
+
    -----------------------------
    -- Find_Static_Alternative --
    -----------------------------
@@ -3054,57 +3495,6 @@ package body Sem_Util is
    end Get_Name_Entity_Id;
 
    ---------------------------
-   -- Get_Subprogram_Entity --
-   ---------------------------
-
-   function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
-      Nam  : Node_Id;
-      Proc : Entity_Id;
-
-   begin
-      if Nkind (Nod) = N_Accept_Statement then
-         Nam := Entry_Direct_Name (Nod);
-
-      --  For an entry call, the prefix of the call is a selected component.
-      --  Need additional code for internal calls ???
-
-      elsif Nkind (Nod) = N_Entry_Call_Statement then
-         if Nkind (Name (Nod)) = N_Selected_Component then
-            Nam := Entity (Selector_Name (Name (Nod)));
-         else
-            Nam := Empty;
-         end if;
-
-      else
-         Nam := Name (Nod);
-      end if;
-
-      if Nkind (Nam) = N_Explicit_Dereference then
-         Proc := Etype (Prefix (Nam));
-      elsif Is_Entity_Name (Nam) then
-         Proc := Entity (Nam);
-      else
-         return Empty;
-      end if;
-
-      if Is_Object (Proc) then
-         Proc := Etype (Proc);
-      end if;
-
-      if Ekind (Proc) = E_Access_Subprogram_Type then
-         Proc := Directly_Designated_Type (Proc);
-      end if;
-
-      if not Is_Subprogram (Proc)
-        and then Ekind (Proc) /= E_Subprogram_Type
-      then
-         return Empty;
-      else
-         return Proc;
-      end if;
-   end Get_Subprogram_Entity;
-
-   ---------------------------
    -- Get_Referenced_Object --
    ---------------------------
 
@@ -3122,6 +3512,22 @@ package body Sem_Util is
       return R;
    end Get_Referenced_Object;
 
+   ------------------------
+   -- Get_Renamed_Entity --
+   ------------------------
+
+   function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
+      R : Entity_Id;
+
+   begin
+      R := E;
+      while Present (Renamed_Entity (R)) loop
+         R := Renamed_Entity (R);
+      end loop;
+
+      return R;
+   end Get_Renamed_Entity;
+
    -------------------------
    -- Get_Subprogram_Body --
    -------------------------
@@ -3140,16 +3546,67 @@ package body Sem_Util is
 
       else           --  Nkind (Decl) = N_Subprogram_Declaration
 
-         if Present (Corresponding_Body (Decl)) then
-            return Unit_Declaration_Node (Corresponding_Body (Decl));
+         if Present (Corresponding_Body (Decl)) then
+            return Unit_Declaration_Node (Corresponding_Body (Decl));
+
+         --  Imported subprogram case
+
+         else
+            return Empty;
+         end if;
+      end if;
+   end Get_Subprogram_Body;
+
+   ---------------------------
+   -- Get_Subprogram_Entity --
+   ---------------------------
+
+   function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
+      Nam  : Node_Id;
+      Proc : Entity_Id;
+
+   begin
+      if Nkind (Nod) = N_Accept_Statement then
+         Nam := Entry_Direct_Name (Nod);
+
+      --  For an entry call, the prefix of the call is a selected component.
+      --  Need additional code for internal calls ???
+
+      elsif Nkind (Nod) = N_Entry_Call_Statement then
+         if Nkind (Name (Nod)) = N_Selected_Component then
+            Nam := Entity (Selector_Name (Name (Nod)));
+         else
+            Nam := Empty;
+         end if;
+
+      else
+         Nam := Name (Nod);
+      end if;
+
+      if Nkind (Nam) = N_Explicit_Dereference then
+         Proc := Etype (Prefix (Nam));
+      elsif Is_Entity_Name (Nam) then
+         Proc := Entity (Nam);
+      else
+         return Empty;
+      end if;
+
+      if Is_Object (Proc) then
+         Proc := Etype (Proc);
+      end if;
 
-         --  Imported subprogram case
+      if Ekind (Proc) = E_Access_Subprogram_Type then
+         Proc := Directly_Designated_Type (Proc);
+      end if;
 
-         else
-            return Empty;
-         end if;
+      if not Is_Subprogram (Proc)
+        and then Ekind (Proc) /= E_Subprogram_Type
+      then
+         return Empty;
+      else
+         return Proc;
       end if;
-   end Get_Subprogram_Body;
+   end Get_Subprogram_Entity;
 
    -----------------------------
    -- Get_Task_Body_Procedure --
@@ -3848,12 +4305,23 @@ package body Sem_Util is
    --  Start of processing for Has_Preelaborable_Initialization
 
    begin
-      --  Immediate return if already marked as known preelaborable init
+      --  Immediate return if already marked as known preelaborable init. This
+      --  covers types for which this function has already been called once
+      --  and returned True (in which case the result is cached), and also
+      --  types to which a pragma Preelaborable_Initialization applies.
 
       if Known_To_Have_Preelab_Init (E) then
          return True;
       end if;
 
+      --  Other private types never have preelaborable initialization
+
+      if Is_Private_Type (E) then
+         return False;
+      end if;
+
+      --  Here for all non-private view
+
       --  All elementary types have preelaborable initialization
 
       if Is_Elementary_Type (E) then
@@ -3864,17 +4332,30 @@ package body Sem_Util is
       elsif Is_Array_Type (E) then
          Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
 
-      --  Record types have PI if all components have PI
+      --  A derived type has preelaborable initialization if its parent type
+      --  has preelaborable initialization and (in the case of a derived record
+      --  extension) if the non-inherited components all have preelaborable
+      --  initialization. However, a user-defined controlled type with an
+      --  overriding Initialize procedure does not have preelaborable
+      --  initialization.
 
-      elsif Is_Record_Type (E) then
-         Has_PE := True;
-         Check_Components (First_Entity (E));
+      elsif Is_Derived_Type (E) then
+
+         --  First check whether ancestor type has preelaborable initialization
+
+         Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
+
+         --  If OK, check extension components (if any)
+
+         if Has_PE and then Is_Record_Type (E) then
+            Check_Components (First_Entity (E));
+         end if;
 
-         --  Another check here, if this is a controlled type, see if it has a
-         --  user defined Initialize procedure. If so, then there is a special
-         --  rule that means this type does not have PI.
+         --  Check specifically for 10.2.1(11.4/2) exception: a controlled type
+         --  with a user defined Initialize procedure does not have PI.
 
-         if Is_Controlled (E)
+         if Has_PE
+           and then Is_Controlled (E)
            and then Present (Primitive_Operations (E))
          then
             declare
@@ -3895,7 +4376,13 @@ package body Sem_Util is
             end;
          end if;
 
-      --  Protected types, must not have entries, and components must meet
+      --  Record type has PI if it is non private and all components have PI
+
+      elsif Is_Record_Type (E) then
+         Has_PE := True;
+         Check_Components (First_Entity (E));
+
+      --  Protected types must not have entries, and components must meet
       --  same set of rules as for record components.
 
       elsif Is_Protected_Type (E) then
@@ -3907,26 +4394,19 @@ package body Sem_Util is
             Check_Components (First_Private_Entity (E));
          end if;
 
-      --  A derived type has preelaborable initialization if its parent type
-      --  has preelaborable initialization and (in the case of a derived record
-      --  extension) if the non-inherited components all have preelaborable
-      --  initialization. However, a user-defined controlled type with an
-      --  overriding Initialize procedure does not have preelaborable
-      --  initialization.
-
-      --  TBD ???
-
       --  Type System.Address always has preelaborable initialization
 
       elsif Is_RTE (E, RE_Address) then
          Has_PE := True;
 
-      --  In all other cases, type does not have preelaborable init
+      --  In all other cases, type does not have preelaborable initialization
 
       else
          return False;
       end if;
 
+      --  If type has preelaborable initialization, cache result
+
       if Has_PE then
          Set_Known_To_Have_Preelab_Init (E);
       end if;
@@ -4527,6 +5007,23 @@ package body Sem_Util is
       end if;
    end Is_Atomic_Object;
 
+   -------------------------
+   -- Is_Coextension_Root --
+   -------------------------
+
+   function Is_Coextension_Root (N : Node_Id) return Boolean is
+   begin
+      return
+        Nkind (N) = N_Allocator
+          and then Present (Coextensions (N))
+
+         --  Anonymous access discriminants carry a list of all nested
+         --  controlled coextensions.
+
+          and then not Is_Coextension (N)
+          and then not Is_Static_Coextension (N);
+   end Is_Coextension_Root;
+
    --------------------------------------
    -- Is_Controlling_Limited_Procedure --
    --------------------------------------
@@ -5785,6 +6282,17 @@ package body Sem_Util is
       return (U /= 0);
    end Is_True;
 
+   -------------------
+   -- Is_Value_Type --
+   -------------------
+
+   function Is_Value_Type (T : Entity_Id) return Boolean is
+   begin
+      return VM_Target = CLI_Target
+        and then Chars (T) /= No_Name
+        and then Get_Name_String (Chars (T)) = "valuetype";
+   end Is_Value_Type;
+
    -----------------
    -- Is_Variable --
    -----------------
@@ -5878,6 +6386,7 @@ package body Sem_Util is
 
       elsif Nkind (N) = N_Explicit_Dereference
         and then Nkind (Orig_Node) /= N_Explicit_Dereference
+        and then Present (Etype (Orig_Node))
         and then Is_Access_Type (Etype (Orig_Node))
       then
          return Is_Variable_Prefix (Original_Node (Prefix (N)));
@@ -6271,8 +6780,11 @@ package body Sem_Util is
 
          --  Test prefix of component or attribute
 
-         when N_Attribute_Reference  |
-              N_Expanded_Name        |
+         when N_Attribute_Reference =>
+            return N = Prefix (P)
+              and then Name_Modifies_Prefix (Attribute_Name (P));
+
+         when N_Expanded_Name        |
               N_Explicit_Dereference |
               N_Indexed_Component    |
               N_Reference            |
@@ -6280,7 +6792,7 @@ package body Sem_Util is
               N_Slice                =>
             return N = Prefix (P);
 
-            --  Function call arguments are never lvalues
+         --  Function call arguments are never lvalues
 
          when N_Function_Call =>
             return False;
@@ -6288,9 +6800,9 @@ package body Sem_Util is
          --  Positional parameter for procedure, entry,  or accept call
 
          when N_Procedure_Call_Statement |
-              N_Entry_Call_Statement |
+              N_Entry_Call_Statement     |
               N_Accept_Statement
-          =>
+         =>
             declare
                Proc : Entity_Id;
                Form : Entity_Id;
@@ -6385,6 +6897,40 @@ package body Sem_Util is
       end case;
    end May_Be_Lvalue;
 
+   ------------------------------
+   -- Mark_Static_Coextensions --
+   ------------------------------
+
+   procedure Mark_Static_Coextensions (Root_Node : Node_Id) is
+      function Mark_Allocator (N : Node_Id) return Traverse_Result;
+      --  Recognize an allocator node and label it as a static coextension
+
+      --------------------
+      -- Mark_Allocator --
+      --------------------
+
+      function Mark_Allocator (N : Node_Id) return Traverse_Result is
+      begin
+         if Nkind (N) = N_Allocator then
+            Set_Is_Static_Coextension (N);
+         end if;
+
+         return OK;
+      end Mark_Allocator;
+
+      procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
+
+   --  Start of processing for Mark_Static_Coextensions
+
+   begin
+      --  Do not mark allocators that stem from an initial allocator because
+      --  these will never be static.
+
+      if Nkind (Root_Node) /= N_Allocator then
+         Mark_Allocators (Root_Node);
+      end if;
+   end Mark_Static_Coextensions;
+
    ----------------------
    -- Needs_One_Actual --
    ----------------------
@@ -6901,6 +7447,8 @@ package body Sem_Util is
                if Modification_Comes_From_Source then
                   Generate_Reference (Ent, Exp, 'm');
                end if;
+
+               Check_Nested_Access (Ent);
             end if;
 
             Kill_Checks (Ent);
@@ -7060,191 +7608,6 @@ package body Sem_Util is
       end if;
    end Object_Access_Level;
 
-   --------------------------------------
-   -- Overrides_Synchronized_Primitive --
-   --------------------------------------
-
-   function Overrides_Synchronized_Primitive
-     (Def_Id      : Entity_Id;
-      First_Hom   : Entity_Id;
-      Ifaces_List : Elist_Id;
-      In_Scope    : Boolean := True) return Entity_Id
-   is
-      Candidate : Entity_Id;
-      Hom       : Entity_Id;
-
-      function Matches_Prefixed_View_Profile
-        (Subp_Params : List_Id;
-         Over_Params : List_Id) return Boolean;
-      --  Determine if a subprogram parameter profile (Subp_Params)
-      --  matches that of a potentially overriden subprogram (Over_Params).
-      --  Determine if the type of first parameter in the list Over_Params
-      --  is an implemented interface, that is to say, the interface is in
-      --  Ifaces_List.
-
-      -----------------------------------
-      -- Matches_Prefixed_View_Profile --
-      -----------------------------------
-
-      function Matches_Prefixed_View_Profile
-        (Subp_Params : List_Id;
-         Over_Params : List_Id) return Boolean
-      is
-         Subp_Param     : Node_Id;
-         Over_Param     : Node_Id;
-         Over_Param_Typ : Entity_Id;
-
-         function Is_Implemented (Iface : Entity_Id) return Boolean;
-         --  Determine if Iface is implemented by the current task or
-         --  protected type.
-
-         --------------------
-         -- Is_Implemented --
-         --------------------
-
-         function Is_Implemented (Iface : Entity_Id) return Boolean is
-            Iface_Elmt : Elmt_Id;
-
-         begin
-            Iface_Elmt := First_Elmt (Ifaces_List);
-            while Present (Iface_Elmt) loop
-               if Node (Iface_Elmt) = Iface then
-                  return True;
-               end if;
-
-               Next_Elmt (Iface_Elmt);
-            end loop;
-
-            return False;
-         end Is_Implemented;
-
-      --  Start of processing for Matches_Prefixed_View_Profile
-
-      begin
-         Subp_Param := First (Subp_Params);
-         Over_Param := First (Over_Params);
-
-         if Nkind (Parameter_Type (Over_Param)) = N_Access_Definition then
-            Over_Param_Typ :=
-              Etype (Subtype_Mark (Parameter_Type (Over_Param)));
-         else
-            Over_Param_Typ := Etype (Parameter_Type (Over_Param));
-         end if;
-
-         --  The first parameter of the potentially overriden subprogram
-         --  must be an interface implemented by Def_Id.
-
-         if not Is_Interface (Over_Param_Typ)
-           or else not Is_Implemented (Over_Param_Typ)
-         then
-            return False;
-         end if;
-
-         --  This may be a primitive declared after a task or protected type.
-         --  We need to skip the first parameter since it is irrelevant.
-
-         if not In_Scope then
-            Subp_Param := Next (Subp_Param);
-         end if;
-         Over_Param := Next (Over_Param);
-
-         while Present (Subp_Param) and then Present (Over_Param) loop
-
-            --  The two parameters must be mode conformant and both types
-            --  must be the same.
-
-            if Ekind (Defining_Identifier (Subp_Param)) /=
-                 Ekind (Defining_Identifier (Over_Param))
-              or else
-                not Conforming_Types
-                  (Etype (Parameter_Type (Subp_Param)),
-                   Etype (Parameter_Type (Over_Param)),
-                   Subtype_Conformant)
-            then
-               return False;
-            end if;
-
-            Next (Subp_Param);
-            Next (Over_Param);
-         end loop;
-
-         --  One of the two lists contains more parameters than the other
-
-         if Present (Subp_Param) or else Present (Over_Param) then
-            return False;
-         end if;
-
-         return True;
-      end Matches_Prefixed_View_Profile;
-
-   --  Start of processing for Overrides_Synchronized_Primitive
-
-   begin
-      --  At this point the caller should have collected the interfaces
-      --  implemented by the synchronized type.
-
-      pragma Assert (Present (Ifaces_List));
-
-      --  Traverse the homonym chain, looking at a potentially overriden
-      --  subprogram that belongs to an implemented interface.
-
-      Hom := First_Hom;
-      while Present (Hom) loop
-         Candidate := Hom;
-
-         --  Entries can override abstract or null interface procedures
-
-         if Ekind (Def_Id) = E_Entry
-           and then Ekind (Candidate) = E_Procedure
-           and then Nkind (Parent (Candidate)) = N_Procedure_Specification
-           and then (Is_Abstract_Subprogram (Candidate)
-                       or else Null_Present (Parent (Candidate)))
-         then
-            while Present (Alias (Candidate)) loop
-               Candidate := Alias (Candidate);
-            end loop;
-
-            if Matches_Prefixed_View_Profile
-                 (Parameter_Specifications (Parent (Def_Id)),
-                  Parameter_Specifications (Parent (Candidate)))
-            then
-               return Candidate;
-            end if;
-
-         --  Procedure can override abstract or null interface procedures
-
-         elsif Ekind (Def_Id) = E_Procedure
-           and then Ekind (Candidate) = E_Procedure
-           and then Nkind (Parent (Candidate)) = N_Procedure_Specification
-           and then (Is_Abstract_Subprogram (Candidate)
-                       or else Null_Present (Parent (Candidate)))
-           and then Matches_Prefixed_View_Profile
-                      (Parameter_Specifications (Parent (Def_Id)),
-                       Parameter_Specifications (Parent (Candidate)))
-         then
-            return Candidate;
-
-         --  Function can override abstract interface functions
-
-         elsif Ekind (Def_Id) = E_Function
-           and then Ekind (Candidate) = E_Function
-           and then Nkind (Parent (Candidate)) = N_Function_Specification
-           and then Is_Abstract_Subprogram (Candidate)
-           and then Matches_Prefixed_View_Profile
-                      (Parameter_Specifications (Parent (Def_Id)),
-                       Parameter_Specifications (Parent (Candidate)))
-           and then Etype (Result_Definition (Parent (Def_Id))) =
-                    Etype (Result_Definition (Parent (Candidate)))
-         then
-            return Candidate;
-         end if;
-
-         Hom := Homonym (Hom);
-      end loop;
-
-      return Empty;
-   end Overrides_Synchronized_Primitive;
-
    -----------------------
    -- Private_Component --
    -----------------------
@@ -7628,44 +7991,27 @@ package body Sem_Util is
       elsif Is_Tagged_Type (Typ)
         or else Has_Controlled_Component (Typ)
       then
-         return True;
+         return not Is_Value_Type (Typ);
 
       --  Record type
 
       elsif Is_Record_Type (Typ) then
+         declare
+            Comp : Entity_Id;
+         begin
+            Comp := First_Entity (Typ);
+            while Present (Comp) loop
+               if Ekind (Comp) = E_Component
+                  and then Requires_Transient_Scope (Etype (Comp))
+               then
+                  return True;
+               else
+                  Next_Entity (Comp);
+               end if;
+            end loop;
+         end;
 
-         --  In GCC 2, discriminated records always require a transient
-         --  scope because the back end otherwise tries to allocate a
-         --  variable length temporary for the particular variant.
-
-         if Opt.GCC_Version = 2
-           and then Has_Discriminants (Typ)
-         then
-            return True;
-
-         --  For GCC 3, or for a non-discriminated record in GCC 2, we are
-         --  OK if none of the component types requires a transient scope.
-         --  Note that we already know that this is a definite type (i.e.
-         --  has discriminant defaults if it is a discriminated record).
-
-         else
-            declare
-               Comp : Entity_Id;
-            begin
-               Comp := First_Entity (Typ);
-               while Present (Comp) loop
-                  if Ekind (Comp) = E_Component
-                     and then Requires_Transient_Scope (Etype (Comp))
-                  then
-                     return True;
-                  else
-                     Next_Entity (Comp);
-                  end if;
-               end loop;
-            end;
-
-            return False;
-         end if;
+         return False;
 
       --  String literal types never require transient scope
 
@@ -7778,11 +8124,13 @@ package body Sem_Util is
 
       --  Skip volatile and aliased variables, since funny things might
       --  be going on in these cases which we cannot necessarily track.
-      --  Also skip any variable for which an address clause is given.
+      --  Also skip any variable for which an address clause is given,
+      --  or whose address is taken
 
       if Treat_As_Volatile (Ent)
         or else Is_Aliased (Ent)
         or else Present (Address_Clause (Ent))
+        or else Address_Taken (Ent)
       then
          return False;
       end if;
@@ -8252,27 +8600,48 @@ package body Sem_Util is
       Btyp : Entity_Id;
 
    begin
-      --  If the type is an anonymous access type we treat it as being
-      --  declared at the library level to ensure that names such as
-      --  X.all'access don't fail static accessibility checks.
-
-      --  Ada 2005 (AI-230): In case of anonymous access types that are
-      --  component_definition or discriminants of a nonlimited type,
-      --  the level is the same as that of the enclosing component type.
-
       Btyp := Base_Type (Typ);
 
+      --  Ada 2005 (AI-230): For most cases of anonymous access types, we
+      --  simply use the level where the type is declared. This is true for
+      --  stand-alone object declarations, and for anonymous access types
+      --  associated with components the level is the same as that of the
+      --  enclosing composite type. However, special treatment is needed for
+      --  the cases of access parameters, return objects of an anonymous access
+      --  type, and, in Ada 95, access discriminants of limited types.
+
       if Ekind (Btyp) in Access_Kind then
-         if Ekind (Btyp) = E_Anonymous_Access_Type
-           and then not Is_Local_Anonymous_Access (Typ) -- Ada 2005 (AI-230)
-         then
+         if Ekind (Btyp) = E_Anonymous_Access_Type then
+
+            --  If the type is a nonlocal anonymous access type (such as for
+            --  an access parameter) we treat it as being declared at the
+            --  library level to ensure that names such as X.all'access don't
+            --  fail static accessibility checks.
+
+            if not Is_Local_Anonymous_Access (Typ) then
+               return Scope_Depth (Standard_Standard);
 
-            --  If this is a return_subtype, the accessibility level is that
-            --  of the result subtype of the enclosing function.
+            --  If this is a return object, the accessibility level is that of
+            --  the result subtype of the enclosing function. The test here is
+            --  little complicated, because we have to account for extended
+            --  return statements that have been rewritten as blocks, in which
+            --  case we have to find and the Is_Return_Object attribute of the
+            --  itype's associated object. It would be nice to find a way to
+            --  simplify this test, but it doesn't seem worthwhile to add a new
+            --  flag just for purposes of this test. ???
 
-            if Ekind (Scope (Btyp)) = E_Return_Statement then
+            elsif Ekind (Scope (Btyp)) = E_Return_Statement
+              or else
+                (Is_Itype (Btyp)
+                  and then Nkind (Associated_Node_For_Itype (Btyp)) =
+                             N_Object_Declaration
+                  and then Is_Return_Object
+                             (Defining_Identifier
+                                (Associated_Node_For_Itype (Btyp))))
+            then
                declare
                   Scop : Entity_Id;
+
                begin
                   Scop := Scope (Scope (Btyp));
                   while Present (Scop) loop
@@ -8280,11 +8649,11 @@ package body Sem_Util is
                      Scop := Scope (Scop);
                   end loop;
 
-                  return Scope_Depth (Scope (Scop));
-               end;
+                  --  Treat the return object's type as having the level of the
+                  --  function's result subtype (as per RM05-6.5(5.3/2)).
 
-            else
-               return Scope_Depth (Standard_Standard);
+                  return Type_Access_Level (Etype (Scop));
+               end;
             end if;
          end if;
 
@@ -8295,8 +8664,8 @@ package body Sem_Util is
          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
 
          --  AI-402: access discriminants have accessibility based on the
-         --  object rather than the type in Ada2005, so the above
-         --  paragraph doesn't apply
+         --  object rather than the type in Ada 2005, so the above paragraph
+         --  doesn't apply.
 
          --  ??? Needs completion with rules from AI-416
 

gcc/ada/sem_util.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -27,6 +27,7 @@
 --  Package containing utility procedures used throughout the semantics
 
 with Einfo;  use Einfo;
+with Namet;  use Namet;
 with Types;  use Types;
 with Uintp;  use Uintp;
 with Urealp; use Urealp;
@@ -41,6 +42,14 @@ package Sem_Util is
    --  Add A to the list of access types to process when expanding the
    --  freeze node of E.
 
+   procedure Add_Global_Declaration (N : Node_Id);
+   --  These procedures adds a declaration N at the library level, to be
+   --  elaborated before any other code in the unit. It is used for example
+   --  for the entity that marks whether a unit has been elaborated. The
+   --  declaration is added to the Declarations list of the Aux_Decls_Node
+   --  for the current unit. The declarations are added in the current scope,
+   --  so the caller should push a new scope as required before the call.
+
    function Alignment_In_Bits (E : Entity_Id) return Uint;
    --  If the alignment of the type or object E is currently known to the
    --  compiler, then this function returns the alignment value in bits.
@@ -120,6 +129,11 @@ package Sem_Util is
    --  place error message on node N. Used in  object declarations, type
    --  conversions, qualified expressions.
 
+   procedure Check_Nested_Access (Ent : Entity_Id);
+   --  Check whether Ent denotes an entity declared in an uplevel scope, which
+   --  is accessed inside a nested procedure, and set Has_Up_Level_Access flag
+   --  accordingly. This is currently only enabled for VM_Target /= No_VM.
+
    procedure Check_Potentially_Blocking_Operation (N : Node_Id);
    --  N is one of the statement forms that is a potentially blocking
    --  operation. If it appears within a protected action, emit warning.
@@ -138,6 +152,12 @@ package Sem_Util is
    --  directly or indirectly implemented by T. Exclude_Parent_Interfaces is
    --  used to avoid addition of inherited interfaces to the generated list.
 
+   procedure Collect_Interface_Components
+     (Tagged_Type     : Entity_Id;
+      Components_List : out Elist_Id);
+   --  Ada 2005 (AI-251): Collect all the tag components associated with the
+   --  secondary dispatch tables of a tagged type.
+
    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id;
    --  Called upon type derivation and extension. We scan the declarative
    --  part in  which the type appears, and collect subprograms that have
@@ -258,6 +278,18 @@ package Sem_Util is
    --  denotes when analyzed. Subsequent uses of this id on a different
    --  type denote the discriminant at the same position in this new type.
 
+   function Find_Overridden_Synchronized_Primitive
+     (Def_Id      : Entity_Id;
+      First_Hom   : Entity_Id;
+      Ifaces_List : Elist_Id;
+      In_Scope    : Boolean := True) return Entity_Id;
+   --  Determine whether entry or subprogram Def_Id overrides a primitive
+   --  operation that belongs to one of the interfaces in Ifaces_List. A
+   --  specific homonym chain can be specified by setting First_Hom. Flag
+   --  In_Scope is used to designate whether the entry or subprogram was
+   --  declared inside the scope of the synchronized type or after. Return
+   --  the overridden entity or Empty.
+
    function First_Actual (Node : Node_Id) return Node_Id;
    --  Node is an N_Function_Call or N_Procedure_Call_Statement node. The
    --  result returned is the first actual parameter in declaration order
@@ -371,6 +403,12 @@ package Sem_Util is
    --  which is the innermost visible entity with the given name. See the
    --  body of Sem_Ch8 for further details on handling of entity visibility.
 
+   function Get_Renamed_Entity (E : Entity_Id) return Entity_Id;
+   --  Given an entity for an exception, package, subprogram or generic unit,
+   --  returns the ultimately renamed entity if this is a renaming. If this is
+   --  not a renamed entity, returns its argument. It is an error to call this
+   --  with any any other kind of entity.
+
    function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id;
    --  Nod is either a procedure call statement, or a function call, or
    --  an accept statement node. This procedure finds the Entity_Id of the
@@ -524,6 +562,10 @@ package Sem_Util is
    --  Determines if the given node denotes an atomic object in the sense
    --  of the legality checks described in RM C.6(12).
 
+   function Is_Coextension_Root (N : Node_Id) return Boolean;
+   --  Determine whether node N is an allocator which acts as a coextension
+   --  root.
+
    function Is_Controlling_Limited_Procedure
      (Proc_Nam : Entity_Id) return Boolean;
    --  Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure
@@ -657,6 +699,12 @@ package Sem_Util is
    --  Boolean operand (i.e. is either 0 for False, or 1 for True). This
    --  function simply tests if it is True (i.e. non-zero)
 
+   function Is_Value_Type (T : Entity_Id) return Boolean;
+   --  Returns true if type T represents a value type. This is only relevant to
+   --  CIL, will always return false for other targets.
+   --  What is a "value type", since this is not an Ada term, it should be
+   --  defined here ???
+
    function Is_Variable (N : Node_Id) return Boolean;
    --  Determines if the tree referenced by N represents a variable, i.e.
    --  can appear on the left side of an assignment. There is one situation,
@@ -705,6 +753,11 @@ package Sem_Util is
    --  direction. Cases which may possibly be assignments but are not known to
    --  be may return True from May_Be_Lvalue, but False from this function.
 
+   procedure Mark_Static_Coextensions (Root_Node : Node_Id);
+   --  Perform a tree traversal starting from Root_Node while marking every
+   --  allocator as a static coextension. Cleanup for this action is performed
+   --  in Resolve_Allocator.
+
    function May_Be_Lvalue (N : Node_Id) return Boolean;
    --  Determines if N could be an lvalue (e.g. an assignment left hand side).
    --  An lvalue is defined as any expression which appears in a context where
@@ -783,18 +836,6 @@ package Sem_Util is
    --  For convenience, qualified expressions applied to object names
    --  are also allowed as actuals for this function.
 
-   function Overrides_Synchronized_Primitive
-     (Def_Id      : Entity_Id;
-      First_Hom   : Entity_Id;
-      Ifaces_List : Elist_Id;
-      In_Scope    : Boolean := True) return Entity_Id;
-   --  Determine whether entry or subprogram Def_Id overrides a primitive
-   --  operation that belongs to one of the interfaces in Ifaces_List. A
-   --  specific homonym chain can be specified by setting First_Hom. Flag
-   --  In_Scope is used to designate whether the entry or subprogram was
-   --  declared inside the scope of the synchronized type or after. Return
-   --  the overriden entity or Empty.
-
    function Private_Component (Type_Id : Entity_Id) return Entity_Id;
    --  Returns some private component (if any) of the given Type_Id.
    --  Used to enforce the rules on visibility of operations on composite