einfo.ads, einfo.adb (Available_View): New synthesized attribute applicable to…

einfo.ads, einfo.adb (Available_View): New synthesized attribute applicable to types that have the With_Type flag set.

2007-04-20  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Eric Botcazou  <ebotcazou@adacore.com>
	    Arnaud Charlet  <charlet@adacore.com>

	* einfo.ads, einfo.adb (Available_View): New synthesized attribute
	applicable to types that have the With_Type flag set. Returns the
	non-limited view of the type, if available, otherwise the type itself.
	For class-wide types, there is no direct link in the tree, so we have
	to retrieve the class-wide type of the non-limited view of the Etype.
	New attributes Static_Initialization and Static_Elaboration_Desired.
	Remove the pragma Thread_Body, and the associated flag
	Is_Thread_Body in entities, and all related code.
	(Suppress_Value_Tracking_On_Call): New flag
	E_Exception has Esize and Alignment fields
	(Universal_Aliasing): New function.
	(Set_Universal_Aliasing): New procedure.
	(Write_Entity_Flags): Deal with Universal_Aliasing flag.
	(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.
	(Related_Interface): New attribute. Present in dispatch table pointer
	components of records. Set to point to the entity of the corresponding
	interface type.
	(Is_By_Reference_Type): Recurse on the full view of an incomplete type.
	(Original_Access_Type): Remove, not needed.
	(Root_Type): Handle properly subtypes of class-wide-types.
	Update comments.

	* sem_ch4.adb (Analyze_Explicit_Dereference): Add support for
	class-wide types visible through limited-with clauses.
	(Try_Primitive_Operation): When examining all primitive operations of a
	tagged type, do not consider subprograms labeled as hidden unless they
	belong to a private generic type with a tagged parent.
	(Try_Object_Operation): Extensive rewriting, to handle properly various
	overloading cases, when several ancestors may have class-wide operations
	that are possible candidates, and when the overloaded functions return
	array types and have defaulted parameters so that the call may be
	interpreted as an indexing.
	(Analyze_Allocator): Remove Mark_Allocator and its invocation.
	(Process_Function_Call): use Next, rather than Next_Actual, to analyze
	successive actuals before analyzing the call itself.
	(Try_Primitive_Operation): A primitive operation is compatible with the
	prefix if the prefix has a synchronized type and the type of the formal
	is its corresponding record, as can be the case when the primitive
	operation is declared outside of the body of the type.
	(Traverse_Homonyms): New subprocedure of Try_Class_Wide_Operation, to
	perform homonym traversal, looking for class-wide operation matches
	(formerly done in statements of Try_Class_Wide_Operation). Matches on
	access parameters are now restricted to anonymous access types.
	(Mark_Allocator): An allocator with a discriminant association parent is
	a coextension.
	(Try_One_Prefix_Interpretation): If the type of the object is
	incomplete, as can be happen when it is a limited view obtained through
	a limited_with_clause, the selected component is not part of a prefixed
	call.
	(Complete_Object_Operation): Diagnose properly an object that is not
	aliased when the corresponding controlling formal is an access
	parameter.
	(Try_Primitive_Operation, Try_Class_Wide_Operation): Diagnose properly
	ambiguous calls in prefixed notation, where two primitives differ only
	in that the controlling argument of one is an access parameter.

	* sem_ch6.adb (Has_Single_Return): Add guard in code that determines
	whether a function that returns an unconstrained type can be inlined.
	(Process_Formals): Diagnose properly the illegal use of an incomplete
	type in the profile of an access_to_subprogram declaration.
	(Check_Synchronized_Overriding): Nothing check for concurrent types, the
	operations are attached to the corresponding record.
	(Analyze_Subprogram_Specification): Add variables Formal and Formal_Typ.
	When processing a primitive of a concurrent type which implements an
	interface change the type of all controlling formals to that of the
	corresponding record type.
	(Check_Synchronized_Overriding): Relax the conditional logic when trying
	to determine the tagged type to which a primitive belongs.
	(Check_Conventions): Capture condition to ignore a primitive operation
	(which is shared between the loop in Check_Conventions and the one in
	Check_Convention) in a new local function Skip_Check.
	(Check_Convention): Rename Prim_Op to Second_Prim_Op to avoid possible
	confusion with Check_Conventions' own Prim_Op local variable.
	(Create_Extra_Formals): Test for a tagged result type rather than a
	controlling result when determining whether to add a BIP_Alloc_Form
	formal and a BIP_Final_List formal to the function.
	(Check_Conformance); For parameters that are anonymous access types,
	subtype conformance requires that the not null and the constant
	indicators must match
	(Check_Synchronized_Overriding): New parameter Formal_Typ. Add machinery
	to retrieve the appropriate type when processing a concurrent type
	declared within a generic. Minor comment reformatting. Change invocation
	of Overrides_Synchronized_Primitive to Find_Overridden_Synchronized_Pri-
	mitive.
	(Analyze_Subprogram_Body): If the return type of a function is an
	anonymous access to the limited view of a class-wide type, and the
	non-limited view of the type is available, update the type of the
	function so that code can be generated.
	(Process_Formals): In case of access-subtype itype whose designated
	type is also an itype (situation that happens now with access to
	subprograms) we mark the access-type itype with the Has_Delayed_Freeze
	attribute to avoid backend problems.
	(Check_Return_Subtype_Indication): Replace R_Type with R_Stm_Type in
	init of R_Stm_Type_Is_Anon_Access. Also check that base types of the
	anonymous types' designated types are same before testing
	Subtypes_Statically_Match.
	(Create_Extra_Formals): Test for a named access parameter that is a
	controlling formal as an additional condition for adding an
	accessibility level formal. This can occur in the subp type created for
	dispatching calls in Expand_Dispatching_Call, and allows calling
	Create_Extra_Formals from that procedure rather than special-casing the
	extra formals there.
	(Create_Extra_Formals): Add BIP_Alloc_Form and BIP_Final_List formals
	when the function has a controlling result.
	(Check_Returns): Add much more knowledge of the optimization of local
	raise statements to gotos, to retain proper warnings in this case.
	(Check_Statement_Sequence): Ignore N_Push_xxx_Label and N_Pop_xxx_Label
	nodes when looking for last statement.

	* sem_type.ads, sem_type.adb (Specific_Type): Add support for
	class-wide types visible through limited with clauses.
	(Add_One_Interp): If the operands are anonymous access types, the
	predefined operator on universal_access is immediately visibles
	(Find_Unique_Type): Handle anonymous access to subprogram types just as
	other anonymous access types.
	(Disambiguate): Take into account CIL convention.
	(Interface_Present_In_Ancestor): Add support for class-wide interfaces.

From-SVN: r125390

gcc/ada/einfo.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- --
@@ -35,7 +35,6 @@ pragma Style_Checks (All_Checks);
 --  Turn off subprogram ordering, not used for this unit
 
 with Atree;  use Atree;
-with Namet;  use Namet;
 with Nlists; use Nlists;
 with Sinfo;  use Sinfo;
 with Stand;  use Stand;
@@ -220,6 +219,8 @@ package body Einfo is
 
    --    Overridden_Operation            Node26
    --    Package_Instantiation           Node26
+   --    Related_Interface               Node26
+   --    Static_Initialization           Node26
 
    --    Wrapped_Entity                  Node27
 
@@ -318,7 +319,7 @@ package body Einfo is
    --    Is_CPP_Class                    Flag74
    --    Has_Non_Standard_Rep            Flag75
    --    Is_Constructor                  Flag76
-   --    Is_Thread_Body                  Flag77
+   --    Static_Elaboration_Desired      Flag77
    --    Is_Tag                          Flag78
    --    Has_All_Calls_Remote            Flag79
    --    Is_Constr_Subt_For_U_Nominal    Flag80
@@ -470,8 +471,26 @@ package body Einfo is
    --    Has_Pragma_Unreferenced_Objects Flag212
    --    Requires_Overriding             Flag213
    --    Has_RACW                        Flag214
-
-   --    (unused)                        Flag215
+   --    Has_Up_Level_Access             Flag215
+   --    Universal_Aliasing              Flag216
+   --    Suppress_Value_Tracking_On_Call Flag217
+
+   --    (unused)                        Flag77
+
+   --    (unused)                        Flag218
+   --    (unused)                        Flag219
+   --    (unused)                        Flag220
+
+   --    (unused)                        Flag221
+   --    (unused)                        Flag222
+   --    (unused)                        Flag223
+   --    (unused)                        Flag224
+   --    (unused)                        Flag225
+   --    (unused)                        Flag226
+   --    (unused)                        Flag227
+   --    (unused)                        Flag228
+   --    (unused)                        Flag229
+   --    (unused)                        Flag230
 
    -----------------------
    -- Local subprograms --
@@ -1387,7 +1406,6 @@ package body Einfo is
 
    function Has_Stream_Size_Clause (Id : E) return B is
    begin
-      pragma Assert (Is_Elementary_Type (Id));
       return Flag184 (Id);
    end Has_Stream_Size_Clause;
 
@@ -1412,6 +1430,15 @@ package body Einfo is
       return Flag72 (Id);
    end Has_Unknown_Discriminants;
 
+   function Has_Up_Level_Access (Id : E) return B is
+   begin
+      pragma Assert
+        (Ekind (Id) = E_Variable
+          or else Ekind (Id) = E_Constant
+          or else Ekind (Id) = E_Loop_Parameter);
+      return Flag215 (Id);
+   end Has_Up_Level_Access;
+
    function Has_Volatile_Components (Id : E) return B is
    begin
       return Flag87 (Implementation_Base_Type (Id));
@@ -1734,7 +1761,6 @@ package body Einfo is
 
    function Is_Limited_Interface (Id : E) return B is
    begin
-      pragma Assert (Is_Interface (Id));
       return Flag197 (Id);
    end Is_Limited_Interface;
 
@@ -1897,11 +1923,6 @@ package body Einfo is
       return Flag200 (Id);
    end Is_Task_Interface;
 
-   function Is_Thread_Body (Id : E) return B is
-   begin
-      return Flag77 (Id);
-   end Is_Thread_Body;
-
    function Is_True_Constant (Id : E) return B is
    begin
       return Flag163 (Id);
@@ -2144,14 +2165,6 @@ package body Einfo is
       return Node24 (Id);
    end Obsolescent_Warning;
 
-   function Original_Access_Type (Id : E) return E is
-   begin
-      pragma Assert
-        (Ekind (Id) = E_Access_Subprogram_Type
-           or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
-      return Node21 (Id);
-   end Original_Access_Type;
-
    function Original_Array_Type (Id : E) return E is
    begin
       pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
@@ -2282,6 +2295,12 @@ package body Einfo is
       return Node15 (Id);
    end Related_Instance;
 
+   function Related_Interface (Id : E) return E is
+   begin
+      pragma Assert (Ekind (Id) = E_Component);
+      return Node26 (Id);
+   end Related_Interface;
+
    function Renamed_Entity (Id : E) return N is
    begin
       return Node18 (Id);
@@ -2404,6 +2423,19 @@ package body Einfo is
       return Node15 (Implementation_Base_Type (Id));
    end Storage_Size_Variable;
 
+   function Static_Elaboration_Desired (Id : E) return B is
+   begin
+      pragma Assert (Ekind (Id) = E_Package);
+      return Flag77 (Id);
+   end Static_Elaboration_Desired;
+
+   function Static_Initialization (Id : E) return N is
+   begin
+      pragma Assert
+        (Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id));
+      return Node26 (Id);
+   end Static_Initialization;
+
    function Stored_Constraint (Id : E) return L is
    begin
       pragma Assert
@@ -2441,6 +2473,11 @@ package body Einfo is
       return Flag165 (Id);
    end Suppress_Style_Checks;
 
+   function Suppress_Value_Tracking_On_Call (Id : E) return B is
+   begin
+      return Flag217 (Id);
+   end Suppress_Value_Tracking_On_Call;
+
    function Task_Body_Procedure (Id : E) return N is
    begin
       pragma Assert (Ekind (Id) in Task_Kind);
@@ -2458,6 +2495,12 @@ package body Einfo is
       return Node19 (Id);
    end Underlying_Full_View;
 
+   function Universal_Aliasing (Id : E) return B is
+   begin
+      pragma Assert (Is_Type (Id));
+      return Flag216 (Base_Type (Id));
+   end Universal_Aliasing;
+
    function Unset_Reference (Id : E) return N is
    begin
       return Node16 (Id);
@@ -3445,6 +3488,15 @@ package body Einfo is
       Set_Flag101 (Id, V);
    end Set_Has_Nested_Block_With_Handler;
 
+   procedure Set_Has_Up_Level_Access (Id : E; V : B := True) is
+   begin
+      pragma Assert
+        (Ekind (Id) = E_Variable
+          or else Ekind (Id) = E_Constant
+          or else Ekind (Id) = E_Loop_Parameter);
+      Set_Flag215 (Id, V);
+   end Set_Has_Up_Level_Access;
+
    procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is
    begin
       pragma Assert (Base_Type (Id) = Id);
@@ -3919,7 +3971,8 @@ package body Einfo is
           or else Ekind (Id) = E_Record_Subtype
           or else Ekind (Id) = E_Record_Type_With_Private
           or else Ekind (Id) = E_Record_Subtype_With_Private
-          or else Ekind (Id) = E_Class_Wide_Type);
+          or else Ekind (Id) = E_Class_Wide_Type
+          or else Ekind (Id) = E_Class_Wide_Subtype);
       Set_Flag186 (Id, V);
    end Set_Is_Interface;
 
@@ -4137,11 +4190,6 @@ package body Einfo is
       Set_Flag55 (Id, V);
    end Set_Is_Tagged_Type;
 
-   procedure Set_Is_Thread_Body (Id : E; V : B := True) is
-   begin
-      Set_Flag77 (Id, V);
-   end Set_Is_Thread_Body;
-
    procedure Set_Is_Task_Interface (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Interface (Id));
@@ -4394,14 +4442,6 @@ package body Einfo is
       Set_Node24 (Id, V);
    end Set_Obsolescent_Warning;
 
-   procedure Set_Original_Access_Type (Id : E; V : E) is
-   begin
-      pragma Assert
-        (Ekind (Id) = E_Access_Subprogram_Type
-           or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
-      Set_Node21 (Id, V);
-   end Set_Original_Access_Type;
-
    procedure Set_Original_Array_Type (Id : E; V : E) is
    begin
       pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
@@ -4532,6 +4572,12 @@ package body Einfo is
       Set_Node15 (Id, V);
    end Set_Related_Instance;
 
+   procedure Set_Related_Interface (Id : E; V : E) is
+   begin
+      pragma Assert (Ekind (Id) = E_Component);
+      Set_Node26 (Id, V);
+   end Set_Related_Interface;
+
    procedure Set_Renamed_Entity (Id : E; V : N) is
    begin
       Set_Node18 (Id, V);
@@ -4656,6 +4702,19 @@ package body Einfo is
       Set_Node15 (Id, V);
    end Set_Storage_Size_Variable;
 
+   procedure Set_Static_Elaboration_Desired (Id : E; V : B) is
+   begin
+      pragma Assert (Ekind (Id) = E_Package);
+      Set_Flag77 (Id, V);
+   end Set_Static_Elaboration_Desired;
+
+   procedure Set_Static_Initialization (Id : E; V : N) is
+   begin
+      pragma Assert
+        (Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id));
+      Set_Node26 (Id, V);
+   end Set_Static_Initialization;
+
    procedure Set_Stored_Constraint (Id : E; V : L) is
    begin
       pragma Assert (Nkind (Id) in N_Entity);
@@ -4696,6 +4755,11 @@ package body Einfo is
       Set_Flag165 (Id, V);
    end Set_Suppress_Style_Checks;
 
+   procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True) is
+   begin
+      Set_Flag217 (Id, V);
+   end Set_Suppress_Value_Tracking_On_Call;
+
    procedure Set_Task_Body_Procedure (Id : E; V : N) is
    begin
       pragma Assert (Ekind (Id) in Task_Kind);
@@ -4713,6 +4777,12 @@ package body Einfo is
       Set_Node19 (Id, V);
    end Set_Underlying_Full_View;
 
+   procedure Set_Universal_Aliasing (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Type (Id) and then Base_Type (Id) = Id);
+      Set_Flag216 (Id, V);
+   end Set_Universal_Aliasing;
+
    procedure Set_Unset_Reference (Id : E; V : N) is
    begin
       Set_Node16 (Id, V);
@@ -5082,6 +5152,28 @@ package body Einfo is
       Set_Last_Entity (V, Id);
    end Append_Entity;
 
+   --------------------
+   -- Available_View --
+   --------------------
+
+   function Available_View (Id : E) return E is
+   begin
+      if Is_Incomplete_Type (Id)
+        and then Present (Non_Limited_View (Id))
+      then
+         return Non_Limited_View (Id);
+
+      elsif Is_Class_Wide_Type (Id)
+        and then Is_Incomplete_Type (Etype (Id))
+        and then Present (Non_Limited_View (Etype (Id)))
+      then
+         return Class_Wide_Type (Non_Limited_View (Etype (Id)));
+
+      else
+         return Id;
+      end if;
+   end Available_View;
+
    ---------------
    -- Base_Type --
    ---------------
@@ -5816,6 +5908,8 @@ package body Einfo is
    -- Is_By_Reference_Type --
    --------------------------
 
+   --  This function knows too much semantics, it should be in sem_util ???
+
    function Is_By_Reference_Type (Id : E) return B is
       Btype : constant Entity_Id := Base_Type (Id);
 
@@ -5828,7 +5922,6 @@ package body Einfo is
       elsif Is_Private_Type (Btype) then
          declare
             Utyp : constant Entity_Id := Underlying_Type (Btype);
-
          begin
             if No (Utyp) then
                return False;
@@ -5837,6 +5930,17 @@ package body Einfo is
             end if;
          end;
 
+      elsif Is_Incomplete_Type (Btype) then
+         declare
+            Ftyp : constant Entity_Id := Full_View (Btype);
+         begin
+            if No (Ftyp) then
+               return False;
+            else
+               return Is_By_Reference_Type (Ftyp);
+            end if;
+         end;
+
       elsif Is_Concurrent_Type (Btype) then
          return True;
 
@@ -6027,9 +6131,12 @@ package body Einfo is
 
       elsif Is_Record_Type (Btype) then
 
+         if Is_Limited_Interface (Id) then
+            return True;
+
          --  AI-419: limitedness is not inherited from a limited interface
 
-         if Is_Limited_Record (Rtype) then
+         elsif Is_Limited_Record (Rtype) then
             return not Is_Interface (Rtype)
               or else Is_Protected_Interface (Rtype)
               or else Is_Synchronized_Interface (Rtype)
@@ -6455,6 +6562,9 @@ package body Einfo is
       if Ekind (T) = E_Class_Wide_Type then
          return Etype (T);
 
+      elsif Ekind (T) = E_Class_Wide_Subtype then
+         return Etype (Base_Type (T));
+
       --  All other cases
 
       else
@@ -6933,6 +7043,7 @@ package body Einfo is
       W ("Has_Task",                        Flag30  (Id));
       W ("Has_Unchecked_Union",             Flag123 (Id));
       W ("Has_Unknown_Discriminants",       Flag72  (Id));
+      W ("Has_Up_Level_Access",             Flag215 (Id));
       W ("Has_Volatile_Components",         Flag87  (Id));
       W ("Has_Xref_Entry",                  Flag182 (Id));
       W ("In_Package_Body",                 Flag48  (Id));
@@ -7019,7 +7130,6 @@ package body Einfo is
       W ("Is_Tag",                          Flag78  (Id));
       W ("Is_Tagged_Type",                  Flag55  (Id));
       W ("Is_Task_Interface",               Flag200 (Id));
-      W ("Is_Thread_Body",                  Flag77  (Id));
       W ("Is_True_Constant",                Flag163 (Id));
       W ("Is_Unchecked_Union",              Flag117 (Id));
       W ("Is_Unsigned_Type",                Flag144 (Id));
@@ -7056,11 +7166,14 @@ package body Einfo is
       W ("Sec_Stack_Needed_For_Return",     Flag167 (Id));
       W ("Size_Depends_On_Discriminant",    Flag177 (Id));
       W ("Size_Known_At_Compile_Time",      Flag92  (Id));
+      W ("Static_Elaboration_Desired",      Flag77  (Id));
       W ("Strict_Alignment",                Flag145 (Id));
       W ("Suppress_Elaboration_Warnings",   Flag148 (Id));
       W ("Suppress_Init_Proc",              Flag105 (Id));
       W ("Suppress_Style_Checks",           Flag165 (Id));
+      W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
       W ("Treat_As_Volatile",               Flag41  (Id));
+      W ("Universal_Aliasing",              Flag216 (Id));
       W ("Uses_Sec_Stack",                  Flag95  (Id));
       W ("Vax_Float",                       Flag151 (Id));
       W ("Warnings_Off",                    Flag96  (Id));
@@ -7360,6 +7473,7 @@ package body Einfo is
               E_Component                                  |
               E_Constant                                   |
               E_Discriminant                               |
+              E_Exception                                  |
               E_In_Parameter                               |
               E_In_Out_Parameter                           |
               E_Out_Parameter                              |
@@ -7434,6 +7548,7 @@ package body Einfo is
          when Type_Kind                                    |
               Formal_Kind                                  |
               E_Constant                                   |
+              E_Exception                                  |
               E_Variable                                   |
               E_Loop_Parameter                             =>
             Write_Str ("Alignment");
@@ -7822,10 +7937,6 @@ package body Einfo is
               Modular_Integer_Kind                         =>
             Write_Str ("Original_Array_Type");
 
-         when E_Access_Subprogram_Type                     |
-              E_Access_Protected_Subprogram_Type           =>
-            Write_Str ("Original_Access_Type");
-
          when others                                       =>
             Write_Str ("Field21??");
       end case;
@@ -8003,13 +8114,21 @@ package body Einfo is
    procedure Write_Field26_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
+         when E_Component                                  =>
+            Write_Str ("Related_Interface");
+
          when E_Generic_Package                            |
               E_Package                                    =>
             Write_Str ("Package_Instantiation");
 
          when E_Procedure                                  |
               E_Function                                   =>
+
+            if Is_Dispatching_Operation (Id) then
                Write_Str ("Overridden_Operation");
+            else
+               Write_Str ("Static_Initialization");
+            end if;
 
          when others                                       =>
             Write_Str ("Field26??");

gcc/ada/einfo.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- --
@@ -31,6 +31,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Namet;  use Namet;
 with Snames; use Snames;
 with Types;  use Types;
 with Uintp;  use Uintp;
@@ -329,8 +330,10 @@ package Einfo is
 
 --    Access_Disp_Table (Elist16) [implementation base type only]
 --       Present in record type entities. For a tagged type, points to the
---       dispatch tables associated with the tagged type. For a non-tagged
---       record, contains Empty.
+--       dispatch tables associated with the tagged type; the last entity of
+--       this list is an access type declaration used to expand dispatching
+--       calls through the primary dispatch table. For a non-tagged record,
+--       contains Empty.
 
 --    Address_Clause (synthesized)
 --       Applies to entries, objects and subprograms. Set if an address clause
@@ -357,15 +360,16 @@ package Einfo is
 --       subprogram. Always empty for entries.
 
 --    Alignment (Uint14)
---       Present in entities for types and also in constants, variables,
---       loop parameters, and formal parameters. This indicates the desired
---       alignment for a type, or the actual alignment for an object. A value
---       of zero (Uint_0) indicates that the alignment has not been set yet.
---       The alignment can be set by an explicit alignment clause, or set by
---       the front-end in package Layout, or set by the back-end as part of
---       the back end back-annotation process. The alignment field is also
---       present in E_Exception entities, but there it is used only by the
---       back-end for back annotation.
+--       Present in entities for types and also in constants, variables
+--       (including exceptions where it refers to the static data allocated for
+--       an exception), loop parameters, and formal parameters. This indicates
+--       the desired alignment for a type, or the actual alignment for an
+--       object. A value of zero (Uint_0) indicates that the alignment has not
+--       been set yet. The alignment can be set by an explicit alignment
+--       clause, or set by the front-end in package Layout, or set by the
+--       back-end as part of the back end back-annotation process. The
+--       alignment field is also present in E_Exception entities, but there it
+--       is used only by the back-end for back annotation.
 
 --    Alignment_Clause (synthesized)
 --       Applies to all entities for types and objects. If an alignment
@@ -383,6 +387,13 @@ package Einfo is
 --       subtype then it returns the subtype or type from which the subtype
 --       was obtained, otherwise it returns Empty.
 
+--    Available_View (synthesized)
+--       Applies to types that have the With_Type flag set. Returns the
+--       non-limited view of the type, if available, otherwise the type
+--       itself. For class-wide types, there is no direct link in the tree,
+--       so we have to retrieve the class-wide type of the non-limited view
+--       of the Etype.
+
 --    Associated_Formal_Package (Node12)
 --       Present in packages that are the actuals of formal_packages. Points
 --       to the entity in the declaration for the formal package.
@@ -458,11 +469,19 @@ package Einfo is
 --       Export pragma).
 
 --    Can_Never_Be_Null (Flag38)
---       This flag is present in all entities, but can only be set in an
---       object which can never have a null value. This is used to avoid
---       unncessary resetting of the Is_Known_Non_Null flag for such
---       entities. The cases where this is set True are constant access
---       values initialized to a non-null value, and access parameters.
+--       This flag is present in all entities, but can only be set in an object
+--       which can never have a null value. This is set True for constant
+--       access values initialized to a non-null value. This is also True for
+--       all access parameters in Ada 83 and Ada 95 modes, and for access
+--       parameters that explicily exlude null in Ada 2005.
+--
+--       This is used to avoid unnecessary resetting of the Is_Known_Non_Null
+--       flag for such entities. In Ada 2005 mode, this is also used when
+--       determining subtype conformance of subprogram profiles to ensure
+--       that two formals have the same null-exclusion status.
+--
+--       ??? This is also set on some access types, eg the Etype of the
+--       anonymous access type of a controlling formal.
 
 --    Chars (Name1)
 --       Present in all entities. This field contains an entry into the names
@@ -969,8 +988,9 @@ package Einfo is
 
 --    Esize (Uint12)
 --       Present in all types and subtypes, and also for components, constants,
---       and variables. Contains the Object_Size of the type or of the object.
---       A value of zero indicates that the value is not yet known.
+--       and variables, including exceptions where it refers to the static data
+--       allocated for an exception. Contains the Object_Size of the type or of
+--       the object. A value of zero indicates that the value is not yet known.
 --
 --       For the case of components where a component clause is present, the
 --       value is the value from the component clause, which must be non-
@@ -1342,8 +1362,8 @@ package Einfo is
 --       clause whose entries are successive integers.
 
 --    Has_Controlling_Result (Flag98)
---       Present in E_Function entities. True if The function is a primitive
---       function of a tagged type which can dispatch on result
+--       Present in E_Function entities. True if the function is a primitive
+--       function of a tagged type which can dispatch on result.
 
 --    Has_Controlled_Component (Flag43) [base type only]
 --       Present in all entities. Set only for composite type entities which
@@ -1448,6 +1468,11 @@ package Einfo is
 --       control wrapping of the body in Exp_Ch6 to ensure that the program
 --       error exeption is correctly raised in this case at runtime.
 
+--    Has_Up_Level_Access (Flag215)
+--      Present in E_Variable and E_Constant entities. Set if the entity is
+--      declared in a local procedure p and is accessed in a procedure nested
+--      inside p. Only set when VM_Target /= No_VM currently.
+
 --    Has_Nested_Block_With_Handler (Flag101)
 --       Present in scope entities. Set if there is a nested block within the
 --       scope that has an exception handler and the two scopes are in the
@@ -1543,7 +1568,7 @@ package Einfo is
 --    Known_To_Have_Preelab_Init (Flag207)
 --       Present in all type and subtype entities. If set, then the type is
 --       known to have preelaborable initialization. In the case of a partial
---       view of a private type, it is only possible for this tobe set if a
+--       view of a private type, it is only possible for this to be set if a
 --       pragma Preelaborable_Initialization is given for the type. For other
 --       types, it is never set if the type does not have preelaborable
 --       initialization, it may or may not be set if the type does have
@@ -1640,8 +1665,10 @@ package Einfo is
 --       storage size clause cannot be given to a derived type.
 
 --    Has_Stream_Size_Clause (Flag184)
---       This flag is set on types which have a Stream_Size clause attribute.
---       Used to prevent multiple Stream_Size clauses for a given entity.
+--       This flag is present in all entities. It is set for types which have a
+--       Stream_Size clause attribute. Used to prevent multiple Stream_Size
+--       clauses for a given entity, and also whether it is necessary to check
+--       for a stream size clause.
 
 --    Has_Subprogram_Descriptor (Flag93)
 --       This flag is set on entities for which zero-cost exception subprogram
@@ -2219,8 +2246,9 @@ package Einfo is
 --       type itself (RM 7.3.1 (5)).
 
 --    Is_Limited_Interface (Flag197)
---       Present in types that are interfaces. True if interface is declared
---       limited, or is derived from limited interfaces.
+--       Present in record types and subtypes. True for interface types, if
+--       interface is declared limited, task, protected, or synchronized, or
+--       is derived from a limited interface.
 
 --    Is_Limited_Record (Flag25)
 --       Present in all entities. Set to true for record (sub)types if the
@@ -2229,8 +2257,9 @@ package Einfo is
 
 --    Is_Limited_Type (synthesized)
 --       Applies to all entities. True if entity is a limited type (limited
---       private type, task type, protected type, composite containing a
---       limited component, or a subtype of any of these types).
+--       private type, limited interface type, task type, protected type,
+--       composite containing a limited component, or a subtype of any of
+--       these types).
 
 --    Is_Machine_Code_Subprogram (Flag137)
 --       Present in subprogram entities. Set to indicate that the subprogram
@@ -2488,8 +2517,9 @@ package Einfo is
 --       component type that is a character type.
 
 --    Is_Synchronized_Interface (Flag199)
---       Present_types that are interfaces. True is interface is declared
---       synchronized, or is derived from synchronized interfaces.
+--       Present in types that are interfaces. True if interface is declared
+--       synchronized, task, or protected, or is derived from a synchronized
+--       interface.
 
 --    Is_Tag (Flag78)
 --       Present in E_Component. For regular tagged type this flag is set on
@@ -2511,10 +2541,6 @@ package Einfo is
 --    Is_Task_Type (synthesized)
 --       Applies to all entities, true for task types and subtypes
 
---    Is_Thread_Body (Flag77)
---       Applies to subprogram entities. Set if a valid Thread_Body pragma
---       applies to this subprogram, which is thus a thread body.
-
 --    Is_True_Constant (Flag163)
 --       This flag is set in constants and variables which have an initial
 --       value specified but which are never assigned, partially or in the
@@ -2921,12 +2947,6 @@ package Einfo is
 --       the contents of the corresponding string literal node. This field is
 --       only accessed if the flag Is_Obsolescent is set.
 
---    Original_Access_Type (Node21)
---       Present in access to subprogram types. Anonymous access to protected
---       subprogram types are replaced by an occurrence of an internal access
---       to subprogram type. This field links the replacement entity with the
---       original entity.
-
 --    Original_Array_Type (Node21)
 --       Present in modular types and array types and subtypes. Set only
 --       if the Is_Packed_Array_Type flag is set, indicating that the type
@@ -3111,11 +3131,16 @@ package Einfo is
 --       wrapper package, but for debugging purposes its external symbol
 --       must correspond to the name and scope of the related instance.
 
+--    Related_Interface (Node26)
+--       Present in components associated with secondary dispatch tables
+--       (dispatch table pointers and offset components). Set to point to the
+--       entity of the corresponding interface type.
+
 --    Renamed_Entity (Node18)
---       Present in exceptions, packages and generic units that are defined
---       by a renaming declaration. Denotes the renamed entity, or transit-
---       itively the ultimate renamed entity if there is a chain of renaming
---       declarations.
+--       Present in exceptions, packages, subprograms and generic units. Set
+--       for entities that are defined by a renaming declaration. Denotes the
+--       renamed entity, or transititively the ultimate renamed entity if
+--       there is a chain of renaming declarations. Empty if no renaming.
 
 --    Renamed_Object (Node18)
 --       Present in all objects (constants, variables, components, formal
@@ -3310,6 +3335,19 @@ package Einfo is
 --       this field is present only in the root type (since derived types
 --       share the same storage pool).
 
+--    Static_Elaboration_Desired (Flag77)
+--       Present in library-level packages. Set by the pragma of the same
+--       name, to indicate that static initialization must be attempted for
+--       all types declared in the package, and that a warning must be emitted
+--       for those types to which static initialization is not available.
+
+--    Static_Initialization (Node26)
+--       Present in initialization procedures for types whose objects can be
+--       initialized statically. The value of this attribute is a positional
+--       aggregate whose components are compile-time static values. Used
+--       when available in object declarations to eliminate the call to the
+--       initialization procedure, and to minimize elaboration code.
+
 --    Stored_Constraint (Elist23)
 --       Present in entities that can have discriminants (concurrent types
 --       subtypes, record types and subtypes, private types and subtypes,
@@ -3354,6 +3392,12 @@ package Einfo is
 --       Present in all entities. Suppresses any style checks specifically
 --       associated with the given entity if set.
 
+--    Suppress_Value_Tracking_On_Call (Flag217)
+--       Present in all entities. Set in a scope entity if value tracking is to
+--       be suppressed on any call within the scope. Used when an access to a
+--       local subprogram is computed, to deal with the possibility that this
+--       value may be passed around, and if used, may clobber a local variable.
+
 --    Task_Body_Procedure (Node25)
 --       Present in task types and subtypes. Points to the entity for
 --       the task body procedure (as further described in Exp_Ch9, task
@@ -3414,6 +3458,15 @@ package Einfo is
 --       entity which may or may not be a type, with the intent that if it is a
 --       type, its underlying type is taken.
 
+--    Universal_Aliasing (Flag216) [base type only]
+--       Present in all type entities. Set to direct the back-end to avoid
+--       any optimizations based on type-based alias analysis for this type.
+--       Indicates that objects of this type can alias objects of any other
+--       types, which guarantees that any objects can be referenced through
+--       access types designating this type safely, whatever the actual type
+--       of these objects. In other words, the effect is as though access
+--       types designating this type were subject to No_Strict_Aliasing.
+
 --    Unset_Reference (Node16)
 --       Present in variables and out parameters. This is normally Empty. It
 --       is set to point to an identifier that represents a reference to the
@@ -4310,6 +4363,7 @@ package Einfo is
    --    Referenced_As_LHS                   (Flag36)
    --    Suppress_Elaboration_Warnings       (Flag148)
    --    Suppress_Style_Checks               (Flag165)
+   --    Suppress_Value_Tracking_On_Call     (Flag217)
    --    Was_Hidden                          (Flag196)
 
    --    Declaration_Node                    (synth)
@@ -4354,6 +4408,7 @@ package Einfo is
    --    Has_Specified_Stream_Output         (Flag191)
    --    Has_Specified_Stream_Read           (Flag192)
    --    Has_Specified_Stream_Write          (Flag193)
+   --    Has_Stream_Size_Clause              (Flag184)
    --    Has_Task                            (Flag30)   (base type only)
    --    Has_Unchecked_Union                 (Flag123)  (base type only)
    --    Has_Volatile_Components             (Flag87)   (base type only)
@@ -4368,7 +4423,6 @@ package Einfo is
    --    Is_Frozen                           (Flag4)
    --    Is_Generic_Actual_Type              (Flag94)
    --    Is_Generic_Type                     (Flag13)
-   --    Is_Limited_Interface                (Flag197)
    --    Is_Protected_Interface              (Flag198)
    --    Is_Synchronized_Interface           (Flag199)
    --    Is_Task_Interface                   (Flag200)
@@ -4388,6 +4442,7 @@ package Einfo is
    --    Strict_Alignment                    (Flag145)  (base type only)
    --    Suppress_Init_Proc                  (Flag105)  (base type only)
    --    Treat_As_Volatile                   (Flag41)
+   --    Universal_Aliasing                  (Flag216)  (base type only)
 
    --    Alignment_Clause                    (synth)
    --    Ancestor_Subtype                    (synth)
@@ -4409,14 +4464,12 @@ package Einfo is
    --  E_Access_Protected_Subprogram_Type
    --    Equivalent_Type                     (Node18)
    --    Directly_Designated_Type            (Node20)
-   --    Original_Access_Type                (Node21)
    --    Needs_No_Actuals                    (Flag22)
    --        (plus type attributes)
 
    --  E_Access_Subprogram_Type
    --    Equivalent_Type                     (Node18)   (remote types only)
    --    Directly_Designated_Type            (Node20)
-   --    Original_Access_Type                (Node21)
    --    Needs_No_Actuals                    (Flag22)
    --        (plus type attributes)
 
@@ -4511,6 +4564,7 @@ package Einfo is
    --    Original_Record_Component           (Node22)
    --    Protected_Operation                 (Node23)
    --    DT_Offset_To_Top_Func               (Node25)
+   --    Related_Interface                   (Node26)
    --    Has_Biased_Representation           (Flag139)
    --    Has_Per_Object_Constraint           (Flag154)
    --    Is_Atomic                           (Flag85)
@@ -4540,6 +4594,7 @@ package Einfo is
    --    Has_Biased_Representation           (Flag139)
    --    Has_Completion                      (Flag26)   (constants only)
    --    Has_Size_Clause                     (Flag29)
+   --    Has_Up_Level_Access                 (Flag215)
    --    Has_Volatile_Components             (Flag87)
    --    Is_Atomic                           (Flag85)
    --    Is_Eliminated                       (Flag124)
@@ -4639,6 +4694,7 @@ package Einfo is
    --        (plus type attributes)
 
    --  E_Exception
+   --    Esize                               (Uint12)
    --    Alignment                           (Uint14)
    --    Renamed_Entity                      (Node18)
    --    Register_Exception_Call             (Node20)
@@ -4709,7 +4765,6 @@ package Einfo is
    --    Is_Overriding_Operation             (Flag39)   (non-generic case only)
    --    Is_Private_Descendant               (Flag53)
    --    Is_Pure                             (Flag44)
-   --    Is_Thread_Body                      (Flag77)   (non-generic case only)
    --    Is_Visible_Child_Unit               (Flag116)
    --    Needs_No_Actuals                    (Flag22)
    --    Requires_Overriding                 (Flag213)  (non-generic case only)
@@ -4883,6 +4938,7 @@ package Einfo is
    --    Is_Visible_Child_Unit               (Flag116)
    --    Is_Wrapper_Package                  (synth)    (non-generic case only)
    --    Scope_Depth                         (synth)
+   --    Static_Elaboration_Desired          (Flag77)   (non-generic case only)
 
    --  E_Package_Body
    --    Handler_Records                     (List10)   (non-generic case only)
@@ -4933,6 +4989,7 @@ package Einfo is
    --    Inner_Instances                     (Elist23)  (for generic proc)
    --    Privals_Chain                       (Elist23)  (for protected proc)
    --    Abstract_Interface_Alias            (Node25)
+   --    Static_Initialization               (Node26)   (init_proc only)
    --    Overridden_Operation                (Node26)
    --    Wrapped_Entity                      (Node27)   (non-generic case only)
    --    Extra_Formals                       (Node28)
@@ -4964,7 +5021,6 @@ package Einfo is
    --    Is_Primitive_Wrapper                (Flag195)  (non-generic case only)
    --    Is_Private_Descendant               (Flag53)
    --    Is_Pure                             (Flag44)
-   --    Is_Thread_Body                      (Flag77)   (non-generic case only)
    --    Is_Valued_Procedure                 (Flag127)
    --    Is_Visible_Child_Unit               (Flag116)
    --    Needs_No_Actuals                    (Flag22)
@@ -5025,6 +5081,7 @@ package Einfo is
    --    Is_Constrained                      (Flag12)
    --    Is_Controlled                       (Flag42)   (base type only)
    --    Is_Interface                        (Flag186)
+   --    Is_Limited_Interface                (Flag197)
    --    Reverse_Bit_Order                   (Flag164)  (base type only)
    --    First_Component                     (synth)
    --    First_Component_Or_Discriminant     (synth)
@@ -5052,6 +5109,7 @@ package Einfo is
    --    Is_Constrained                      (Flag12)
    --    Is_Controlled                       (Flag42)   (base type only)
    --    Is_Interface                        (Flag186)
+   --    Is_Limited_Interface                (Flag197)
    --    Reverse_Bit_Order                   (Flag164)  (base type only)
    --    First_Component                     (synth)
    --    First_Component_Or_Discriminant     (synth)
@@ -5157,6 +5215,7 @@ package Einfo is
    --    Never_Set_In_Source                 (Flag115)
    --    Treat_As_Volatile                   (Flag41)
    --    Is_Return_Object                    (Flag209)
+   --    Has_Up_Level_Access                 (Flag215)
    --    Address_Clause                      (synth)
    --    Alignment_Clause                    (synth)
    --    Constant_Value                      (synth)
@@ -5515,6 +5574,7 @@ package Einfo is
    function Has_Missing_Return                  (Id : E) return B;
    function Has_Nested_Block_With_Handler       (Id : E) return B;
    function Has_Forward_Instantiation           (Id : E) return B;
+   function Has_Up_Level_Access                 (Id : E) return B;
    function Has_Non_Standard_Rep                (Id : E) return B;
    function Has_Object_Size_Clause              (Id : E) return B;
    function Has_Per_Object_Constraint           (Id : E) return B;
@@ -5630,7 +5690,6 @@ package Einfo is
    function Is_Tag                              (Id : E) return B;
    function Is_Tagged_Type                      (Id : E) return B;
    function Is_Task_Interface                   (Id : E) return B;
-   function Is_Thread_Body                      (Id : E) return B;
    function Is_True_Constant                    (Id : E) return B;
    function Is_Unchecked_Union                  (Id : E) return B;
    function Is_Unsigned_Type                    (Id : E) return B;
@@ -5672,7 +5731,6 @@ package Einfo is
    function Normalized_Position_Max             (Id : E) return U;
    function Object_Ref                          (Id : E) return E;
    function Obsolescent_Warning                 (Id : E) return N;
-   function Original_Access_Type                (Id : E) return E;
    function Original_Array_Type                 (Id : E) return E;
    function Original_Record_Component           (Id : E) return E;
    function Overridden_Operation                (Id : E) return E;
@@ -5695,6 +5753,7 @@ package Einfo is
    function Register_Exception_Call             (Id : E) return N;
    function Related_Array_Object                (Id : E) return E;
    function Related_Instance                    (Id : E) return E;
+   function Related_Interface                   (Id : E) return E;
    function Renamed_Entity                      (Id : E) return N;
    function Renamed_Object                      (Id : E) return N;
    function Renaming_Map                        (Id : E) return U;
@@ -5716,6 +5775,8 @@ package Einfo is
    function Small_Value                         (Id : E) return R;
    function Spec_Entity                         (Id : E) return E;
    function Storage_Size_Variable               (Id : E) return E;
+   function Static_Elaboration_Desired          (Id : E) return B;
+   function Static_Initialization               (Id : E) return N;
    function Stored_Constraint                   (Id : E) return L;
    function Strict_Alignment                    (Id : E) return B;
    function String_Literal_Length               (Id : E) return U;
@@ -5723,9 +5784,11 @@ package Einfo is
    function Suppress_Elaboration_Warnings       (Id : E) return B;
    function Suppress_Init_Proc                  (Id : E) return B;
    function Suppress_Style_Checks               (Id : E) return B;
+   function Suppress_Value_Tracking_On_Call     (Id : E) return B;
    function Task_Body_Procedure                 (Id : E) return N;
    function Treat_As_Volatile                   (Id : E) return B;
    function Underlying_Full_View                (Id : E) return E;
+   function Universal_Aliasing                  (Id : E) return B;
    function Unset_Reference                     (Id : E) return N;
    function Uses_Sec_Stack                      (Id : E) return B;
    function Vax_Float                           (Id : E) return B;
@@ -5798,6 +5861,7 @@ package Einfo is
    function Address_Clause                      (Id : E) return N;
    function Alignment_Clause                    (Id : E) return N;
    function Ancestor_Subtype                    (Id : E) return E;
+   function Available_View                      (Id : E) return E;
    function Base_Type                           (Id : E) return E;
    function Constant_Value                      (Id : E) return N;
    function Declaration_Node                    (Id : E) return N;
@@ -6035,6 +6099,7 @@ package Einfo is
    procedure Set_Has_Missing_Return              (Id : E; V : B := True);
    procedure Set_Has_Nested_Block_With_Handler   (Id : E; V : B := True);
    procedure Set_Has_Forward_Instantiation       (Id : E; V : B := True);
+   procedure Set_Has_Up_Level_Access             (Id : E; V : B := True);
    procedure Set_Has_Non_Standard_Rep            (Id : E; V : B := True);
    procedure Set_Has_Object_Size_Clause          (Id : E; V : B := True);
    procedure Set_Has_Per_Object_Constraint       (Id : E; V : B := True);
@@ -6157,7 +6222,6 @@ package Einfo is
    procedure Set_Is_Tag                          (Id : E; V : B := True);
    procedure Set_Is_Tagged_Type                  (Id : E; V : B := True);
    procedure Set_Is_Task_Interface               (Id : E; V : B := True);
-   procedure Set_Is_Thread_Body                  (Id : E; V : B := True);
    procedure Set_Is_True_Constant                (Id : E; V : B := True);
    procedure Set_Is_Unchecked_Union              (Id : E; V : B := True);
    procedure Set_Is_Unsigned_Type                (Id : E; V : B := True);
@@ -6199,7 +6263,6 @@ package Einfo is
    procedure Set_Normalized_Position_Max         (Id : E; V : U);
    procedure Set_Object_Ref                      (Id : E; V : E);
    procedure Set_Obsolescent_Warning             (Id : E; V : N);
-   procedure Set_Original_Access_Type            (Id : E; V : E);
    procedure Set_Original_Array_Type             (Id : E; V : E);
    procedure Set_Original_Record_Component       (Id : E; V : E);
    procedure Set_Overridden_Operation            (Id : E; V : E);
@@ -6222,6 +6285,7 @@ package Einfo is
    procedure Set_Register_Exception_Call         (Id : E; V : N);
    procedure Set_Related_Array_Object            (Id : E; V : E);
    procedure Set_Related_Instance                (Id : E; V : E);
+   procedure Set_Related_Interface               (Id : E; V : E);
    procedure Set_Renamed_Entity                  (Id : E; V : N);
    procedure Set_Renamed_Object                  (Id : E; V : N);
    procedure Set_Renaming_Map                    (Id : E; V : U);
@@ -6243,6 +6307,8 @@ package Einfo is
    procedure Set_Small_Value                     (Id : E; V : R);
    procedure Set_Spec_Entity                     (Id : E; V : E);
    procedure Set_Storage_Size_Variable           (Id : E; V : E);
+   procedure Set_Static_Elaboration_Desired      (Id : E; V : B);
+   procedure Set_Static_Initialization           (Id : E; V : N);
    procedure Set_Stored_Constraint               (Id : E; V : L);
    procedure Set_Strict_Alignment                (Id : E; V : B := True);
    procedure Set_String_Literal_Length           (Id : E; V : U);
@@ -6250,9 +6316,11 @@ package Einfo is
    procedure Set_Suppress_Elaboration_Warnings   (Id : E; V : B := True);
    procedure Set_Suppress_Init_Proc              (Id : E; V : B := True);
    procedure Set_Suppress_Style_Checks           (Id : E; V : B := True);
+   procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True);
    procedure Set_Task_Body_Procedure             (Id : E; V : N);
    procedure Set_Treat_As_Volatile               (Id : E; V : B := True);
    procedure Set_Underlying_Full_View            (Id : E; V : E);
+   procedure Set_Universal_Aliasing              (Id : E; V : B := True);
    procedure Set_Unset_Reference                 (Id : E; V : N);
    procedure Set_Uses_Sec_Stack                  (Id : E; V : B := True);
    procedure Set_Vax_Float                       (Id : E; V : B := True);
@@ -6641,6 +6709,7 @@ package Einfo is
    pragma Inline (Has_Task);
    pragma Inline (Has_Unchecked_Union);
    pragma Inline (Has_Unknown_Discriminants);
+   pragma Inline (Has_Up_Level_Access);
    pragma Inline (Has_Volatile_Components);
    pragma Inline (Has_Xref_Entry);
    pragma Inline (Hiding_Loop_Variable);
@@ -6767,7 +6836,6 @@ package Einfo is
    pragma Inline (Is_Tag);
    pragma Inline (Is_Tagged_Type);
    pragma Inline (Is_Task_Interface);
-   pragma Inline (Is_Thread_Body);
    pragma Inline (Is_True_Constant);
    pragma Inline (Is_Task_Type);
    pragma Inline (Is_Type);
@@ -6812,7 +6880,6 @@ package Einfo is
    pragma Inline (Normalized_Position_Max);
    pragma Inline (Object_Ref);
    pragma Inline (Obsolescent_Warning);
-   pragma Inline (Original_Access_Type);
    pragma Inline (Original_Array_Type);
    pragma Inline (Original_Record_Component);
    pragma Inline (Overridden_Operation);
@@ -6836,6 +6903,7 @@ package Einfo is
    pragma Inline (Register_Exception_Call);
    pragma Inline (Related_Array_Object);
    pragma Inline (Related_Instance);
+   pragma Inline (Related_Interface);
    pragma Inline (Renamed_Entity);
    pragma Inline (Renamed_Object);
    pragma Inline (Renaming_Map);
@@ -6857,6 +6925,8 @@ package Einfo is
    pragma Inline (Small_Value);
    pragma Inline (Spec_Entity);
    pragma Inline (Storage_Size_Variable);
+   pragma Inline (Static_Elaboration_Desired);
+   pragma Inline (Static_Initialization);
    pragma Inline (Stored_Constraint);
    pragma Inline (Strict_Alignment);
    pragma Inline (String_Literal_Length);
@@ -6864,9 +6934,11 @@ package Einfo is
    pragma Inline (Suppress_Elaboration_Warnings);
    pragma Inline (Suppress_Init_Proc);
    pragma Inline (Suppress_Style_Checks);
+   pragma Inline (Suppress_Value_Tracking_On_Call);
    pragma Inline (Task_Body_Procedure);
    pragma Inline (Treat_As_Volatile);
    pragma Inline (Underlying_Full_View);
+   pragma Inline (Universal_Aliasing);
    pragma Inline (Unset_Reference);
    pragma Inline (Uses_Sec_Stack);
    pragma Inline (Vax_Float);
@@ -7012,7 +7084,6 @@ package Einfo is
    pragma Inline (Set_Has_Pragma_Pure_Function);
    pragma Inline (Set_Has_Pragma_Unreferenced);
    pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
-   pragma Inline (Set_Known_To_Have_Preelab_Init);
    pragma Inline (Set_Has_Primitive_Operations);
    pragma Inline (Set_Has_Private_Declaration);
    pragma Inline (Set_Has_Qualified_Name);
@@ -7028,10 +7099,12 @@ package Einfo is
    pragma Inline (Set_Has_Specified_Stream_Write);
    pragma Inline (Set_Has_Static_Discriminants);
    pragma Inline (Set_Has_Storage_Size_Clause);
+   pragma Inline (Set_Has_Stream_Size_Clause);
    pragma Inline (Set_Has_Subprogram_Descriptor);
    pragma Inline (Set_Has_Task);
    pragma Inline (Set_Has_Unchecked_Union);
    pragma Inline (Set_Has_Unknown_Discriminants);
+   pragma Inline (Set_Has_Up_Level_Access);
    pragma Inline (Set_Has_Volatile_Components);
    pragma Inline (Set_Has_Xref_Entry);
    pragma Inline (Set_Hiding_Loop_Variable);
@@ -7122,7 +7195,6 @@ package Einfo is
    pragma Inline (Set_Is_Tag);
    pragma Inline (Set_Is_Tagged_Type);
    pragma Inline (Set_Is_Task_Interface);
-   pragma Inline (Set_Is_Thread_Body);
    pragma Inline (Set_Is_True_Constant);
    pragma Inline (Set_Is_Unchecked_Union);
    pragma Inline (Set_Is_Unsigned_Type);
@@ -7135,6 +7207,7 @@ package Einfo is
    pragma Inline (Set_Kill_Elaboration_Checks);
    pragma Inline (Set_Kill_Range_Checks);
    pragma Inline (Set_Kill_Tag_Checks);
+   pragma Inline (Set_Known_To_Have_Preelab_Init);
    pragma Inline (Set_Last_Assignment);
    pragma Inline (Set_Last_Entity);
    pragma Inline (Set_Limited_View);
@@ -7163,7 +7236,6 @@ package Einfo is
    pragma Inline (Set_Normalized_Position_Max);
    pragma Inline (Set_Object_Ref);
    pragma Inline (Set_Obsolescent_Warning);
-   pragma Inline (Set_Original_Access_Type);
    pragma Inline (Set_Original_Array_Type);
    pragma Inline (Set_Original_Record_Component);
    pragma Inline (Set_Overridden_Operation);
@@ -7186,6 +7258,7 @@ package Einfo is
    pragma Inline (Set_Register_Exception_Call);
    pragma Inline (Set_Related_Array_Object);
    pragma Inline (Set_Related_Instance);
+   pragma Inline (Set_Related_Interface);
    pragma Inline (Set_Renamed_Entity);
    pragma Inline (Set_Renamed_Object);
    pragma Inline (Set_Renaming_Map);
@@ -7207,6 +7280,8 @@ package Einfo is
    pragma Inline (Set_Small_Value);
    pragma Inline (Set_Spec_Entity);
    pragma Inline (Set_Storage_Size_Variable);
+   pragma Inline (Set_Static_Elaboration_Desired);
+   pragma Inline (Set_Static_Initialization);
    pragma Inline (Set_Stored_Constraint);
    pragma Inline (Set_Strict_Alignment);
    pragma Inline (Set_String_Literal_Length);
@@ -7214,9 +7289,11 @@ package Einfo is
    pragma Inline (Set_Suppress_Elaboration_Warnings);
    pragma Inline (Set_Suppress_Init_Proc);
    pragma Inline (Set_Suppress_Style_Checks);
+   pragma Inline (Set_Suppress_Value_Tracking_On_Call);
    pragma Inline (Set_Task_Body_Procedure);
    pragma Inline (Set_Treat_As_Volatile);
    pragma Inline (Set_Underlying_Full_View);
+   pragma Inline (Set_Universal_Aliasing);
    pragma Inline (Set_Unset_Reference);
    pragma Inline (Set_Uses_Sec_Stack);
    pragma Inline (Set_Vax_Float);

gcc/ada/sem_ch4.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- --
@@ -346,45 +346,8 @@ package body Sem_Ch4 is
       Acc_Type : Entity_Id;
       Type_Id  : Entity_Id;
 
-      function Mark_Allocator (Nod : Node_Id) return Traverse_Result;
-      --  Ada 2005 AI-162: Traverse the expression for an allocator, to locate
-      --  inner allocators that may specify access discriminants. Such access
-      --  discriminants are coextensions of the enclosing objects. They should
-      --  be allocated from the same storage pool as the enclosing object, and
-      --  deallocated at the same time as the enclosing object. They are
-      --  linked to the enclosing allocator to simplify this sharing.
-      --  On the other hand, access discriminants for stack-allocated objects
-      --  are themselves allocated statically, and do not carry the flag.
-
-      --------------------
-      -- Mark_Allocator --
-      --------------------
-
-      function Mark_Allocator (Nod : Node_Id) return Traverse_Result is
-      begin
-         if Nkind (Nod) = N_Allocator
-           and then Nkind (Parent (Nod)) = N_Index_Or_Discriminant_Constraint
-         then
-            Set_Is_Coextension (Nod);
-
-            if No (Coextensions (N)) then
-               Set_Coextensions (N, New_Elmt_List);
-            end if;
-
-            Append_Elmt (Nod, Coextensions (N));
-         end if;
-
-         return OK;
-      end Mark_Allocator;
-
-      procedure Mark_Coextensions is new Traverse_Proc (Mark_Allocator);
-
-   --  Start of processing for Analyze_Allocator
-
    begin
       Check_Restriction (No_Allocators, N);
-      Set_Coextensions (N, No_Elist);
-      Mark_Coextensions (E);
 
       if Nkind (E) = N_Qualified_Expression then
 
@@ -1293,10 +1256,10 @@ package body Sem_Ch4 is
       if not Is_Overloaded (P) then
          if Is_Access_Type (Etype (P)) then
 
-            --  Set the Etype. We need to go thru Is_For_Access_Subtypes
-            --  to avoid other problems caused by the Private_Subtype
-            --  and it is safe to go to the Base_Type because this is the
-            --  same as converting the access value to its Base_Type.
+            --  Set the Etype. We need to go thru Is_For_Access_Subtypes to
+            --  avoid other problems caused by the Private_Subtype and it is
+            --  safe to go to the Base_Type because this is the same as
+            --  converting the access value to its Base_Type.
 
             declare
                DT : Entity_Id := Designated_Type (Etype (P));
@@ -1308,7 +1271,23 @@ package body Sem_Ch4 is
                   DT := Base_Type (DT);
                end if;
 
+               --  An explicit dereference is a legal occurrence of an
+               --  incomplete type imported through a limited_with clause,
+               --  if the full view is visible.
+
+               if From_With_Type (DT)
+                 and then not From_With_Type (Scope (DT))
+                 and then
+                   (Is_Immediately_Visible (Scope (DT))
+                     or else
+                       (Is_Child_Unit (Scope (DT))
+                          and then Is_Visible_Child_Unit (Scope (DT))))
+               then
+                  Set_Etype (N, Available_View (DT));
+
+               else
                   Set_Etype (N, DT);
+               end if;
             end;
 
          elsif Etype (P) /= Any_Type then
@@ -1466,11 +1445,31 @@ package body Sem_Ch4 is
          Set_Name (N, P);
          Set_Parameter_Associations (N, Exprs);
 
+         --  Analyze actuals prior to analyzing the call itself.
+
          Actual := First (Parameter_Associations (N));
          while Present (Actual) loop
             Analyze (Actual);
             Check_Parameterless_Call (Actual);
-            Next_Actual (Actual);
+
+            --  Move to next actual. Note that we use Next, not Next_Actual
+            --  here. The reason for this is a bit subtle. If a function call
+            --  includes named associations, the parser recognizes the node as
+            --  a call, and it is analyzed as such. If all associations are
+            --  positional, the parser builds an indexed_component node, and
+            --  it is only after analysis of the prefix that the construct
+            --  is recognized as a call, in which case Process_Function_Call
+            --  rewrites the node and analyzes the actuals. If the list of
+            --  actuals is malformed, the parser may leave the node as an
+            --  indexed component (despite the presence of named associations).
+            --  The iterator Next_Actual is equivalent to Next if the list is
+            --  positional, but follows the normalized chain of actuals when
+            --  named associations are present. In this case normalization has
+            --  not taken place, and actuals remain unanalyzed, which leads to
+            --  subsequent crashes or loops if there is an attempt to continue
+            --  analysis of the program.
+
+            Next (Actual);
          end loop;
 
          Analyze_Call (N);
@@ -2448,7 +2447,9 @@ package body Sem_Ch4 is
          Get_Next_Interp (I, It);
       end loop;
 
-      if Etype (N) = Any_Type then
+      if Etype (N) = Any_Type
+        and then not Try_Object_Operation (N)
+      then
          Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
          Set_Entity (Sel, Any_Id);
          Set_Etype  (Sel, Any_Type);
@@ -3008,13 +3009,30 @@ package body Sem_Ch4 is
          --  implements an interface, check whether there is some other
          --  primitive operation with that name.
 
-         if Etype (N) = Any_Type
-           and then Ada_Version >= Ada_05
+         if Ada_Version >= Ada_05
            and then Is_Tagged_Type (Prefix_Type)
+         then
+            if Etype (N) = Any_Type
+              and then Try_Object_Operation (N)
+            then
+               return;
+
+            --  If the context is not syntactically a procedure call, it
+            --  may be a call to a primitive function declared outside of
+            --  the synchronized type.
+
+            --  If the context is a procedure call, there might still be
+            --  an overloading between an entry and a primitive procedure
+            --  declared outside of the synchronized type, called in prefix
+            --  notation. This is harder to disambiguate because in one case
+            --  the controlling formal is implicit ???
+
+            elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement
               and then Try_Object_Operation (N)
             then
                return;
             end if;
+         end if;
 
          Set_Is_Overloaded (N, Is_Overloaded (Sel));
 
@@ -5099,7 +5117,11 @@ package body Sem_Ch4 is
       Is_Subprg_Call : constant Boolean    := K = N_Procedure_Call_Statement
                                                or else K = N_Function_Call;
       Obj            : constant Node_Id    := Prefix (N);
-      Subprog        : constant Node_Id    := Selector_Name (N);
+      Subprog        : constant Node_Id    :=
+                         Make_Identifier (Sloc (Selector_Name (N)),
+                           Chars => Chars (Selector_Name (N)));
+      --  Identifier on which possible interpretations will be collected.
+
       Success        : Boolean := False;
 
       Report_Error : Boolean := False;
@@ -5111,18 +5133,27 @@ package body Sem_Ch4 is
       Node_To_Replace : Node_Id;
       Obj_Type        : Entity_Id := Etype (Obj);
 
+      function Valid_Candidate
+        (Success : Boolean;
+         Call    : Node_Id;
+         Subp    : Entity_Id) return Entity_Id;
+      --  If the subprogram is a valid interpretation, record it, and add
+      --  to the list of interpretations of Subprog.
+
       procedure Complete_Object_Operation
         (Call_Node       : Node_Id;
-         Node_To_Replace : Node_Id;
-         Subprog         : Node_Id);
+         Node_To_Replace : Node_Id);
       --  Make Subprog the name of Call_Node, replace Node_To_Replace with
       --  Call_Node, insert the object (or its dereference) as the first actual
       --  in the call, and complete the analysis of the call.
 
+      procedure Report_Ambiguity (Op : Entity_Id);
+      --  If a prefixed procedure call is ambiguous, indicate whether the
+      --  call includes an implicit dereference or an implicit 'Access.
+
       procedure Transform_Object_Operation
         (Call_Node       : out Node_Id;
-         Node_To_Replace : out Node_Id;
-         Subprog         : Node_Id);
+         Node_To_Replace : out Node_Id);
       --  Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
       --  Call_Node is the resulting subprogram call,
       --  Node_To_Replace is either N or the parent of N, and Subprog
@@ -5134,29 +5165,91 @@ package body Sem_Ch4 is
       --  Traverse all ancestor types looking for a class-wide subprogram
       --  for which the current operation is a valid non-dispatching call.
 
+      procedure Try_One_Prefix_Interpretation (T : Entity_Id);
+      --  If prefix is overloaded, its interpretation may include different
+      --  tagged types, and we must examine the primitive operations and
+      --  the class-wide operations of each in order to find candidate
+      --  interpretations for the call as a whole.
+
       function Try_Primitive_Operation
         (Call_Node       : Node_Id;
          Node_To_Replace : Node_Id) return Boolean;
       --  Traverse the list of primitive subprograms looking for a dispatching
       --  operation for which the current node is a valid call .
 
+      ---------------------
+      -- Valid_Candidate --
+      ---------------------
+
+      function Valid_Candidate
+        (Success : Boolean;
+         Call    : Node_Id;
+         Subp    : Entity_Id) return Entity_Id
+      is
+         Comp_Type : Entity_Id;
+
+      begin
+         --  If the subprogram is a valid interpretation, record it in global
+         --  variable Subprog, to collect all possible overloadings.
+
+         if Success then
+            if Subp /= Entity (Subprog) then
+               Add_One_Interp (Subprog, Subp, Etype (Subp));
+            end if;
+         end if;
+
+         --  If the call may be an indexed call, retrieve component type
+         --  of resulting expression, and add possible interpretation.
+
+         Comp_Type := Empty;
+
+         if Nkind (Call) = N_Function_Call
+             and then Nkind (Parent (N)) = N_Indexed_Component
+             and then Needs_One_Actual (Subp)
+         then
+            if Is_Array_Type (Etype (Subp)) then
+               Comp_Type := Component_Type (Etype (Subp));
+
+            elsif Is_Access_Type (Etype (Subp))
+              and then Is_Array_Type (Designated_Type (Etype (Subp)))
+            then
+               Comp_Type := Component_Type (Designated_Type (Etype (Subp)));
+            end if;
+         end if;
+
+         if Present (Comp_Type)
+              and then Etype (Subprog) /= Comp_Type
+         then
+            Add_One_Interp (Subprog, Subp, Comp_Type);
+         end if;
+
+         if Etype (Call) /= Any_Type then
+            return Subp;
+         else
+            return Empty;
+         end if;
+      end Valid_Candidate;
+
       -------------------------------
       -- Complete_Object_Operation --
       -------------------------------
 
       procedure Complete_Object_Operation
         (Call_Node       : Node_Id;
-         Node_To_Replace : Node_Id;
-         Subprog         : Node_Id)
+         Node_To_Replace : Node_Id)
       is
          Formal_Type  : constant Entity_Id :=
                           Etype (First_Formal (Entity (Subprog)));
          First_Actual : Node_Id;
 
       begin
-         First_Actual := First (Parameter_Associations (Call_Node));
+         --  Place the name of the operation, with its interpretations,
+         --  on the rewritten call.
+
          Set_Name (Call_Node, Subprog);
 
+         First_Actual := First (Parameter_Associations (Call_Node));
+
          --  For cross-reference purposes, treat the new node as being in
          --  the source if the original one is.
 
@@ -5170,8 +5263,21 @@ package body Sem_Ch4 is
          end if;
 
          --  If need be, rewrite first actual as an explicit dereference
+         --  If the call is overloaded, the rewriting can only be done
+         --  once the primitive operation is identified.
+
+         if Is_Overloaded (Subprog) then
+
+            --  The prefix itself may be overloaded, and its interpretations
+            --  must be propagated to the new actual in the call.
+
+            if Is_Overloaded (Obj) then
+               Save_Interps (Obj, First_Actual);
+            end if;
 
-         if not Is_Access_Type (Formal_Type)
+            Rewrite (First_Actual, Obj);
+
+         elsif not Is_Access_Type (Formal_Type)
            and then Is_Access_Type (Etype (Obj))
          then
             Rewrite (First_Actual,
@@ -5189,28 +5295,85 @@ package body Sem_Ch4 is
               Make_Attribute_Reference (Loc,
                 Attribute_Name => Name_Access,
                 Prefix => Relocate_Node (Obj)));
+
+            if not Is_Aliased_View (Obj) then
+               Error_Msg_NE
+                 ("object in prefixed call to& must be aliased"
+                      & " ('R'M'-2005 4.3.1 (13))",
+                 Prefix (First_Actual), Subprog);
+            end if;
+
             Analyze (First_Actual);
 
          else
-            Rewrite (First_Actual, Obj);
+            if Is_Overloaded (Obj) then
+               Save_Interps (Obj, First_Actual);
             end if;
 
-         if Is_Overloaded (Call_Node) then
-            Save_Interps (Call_Node, Node_To_Replace);
+            Rewrite (First_Actual, Obj);
          end if;
 
          Rewrite (Node_To_Replace, Call_Node);
+
+         --  Propagate the interpretations collected in subprog to the new
+         --  function call node, to be resolved from context.
+
+         if Is_Overloaded (Subprog) then
+            Save_Interps (Subprog, Node_To_Replace);
+         else
             Analyze (Node_To_Replace);
+         end if;
       end Complete_Object_Operation;
 
+      ----------------------
+      -- Report_Ambiguity --
+      ----------------------
+
+      procedure Report_Ambiguity (Op : Entity_Id) is
+         Access_Formal : constant Boolean :=
+                           Is_Access_Type (Etype (First_Formal (Op)));
+         Access_Actual : constant Boolean :=
+                           Is_Access_Type (Etype (Prefix (N)));
+
+      begin
+         Error_Msg_Sloc := Sloc (Op);
+
+         if Access_Formal and then not Access_Actual then
+            if Nkind (Parent (Op)) = N_Full_Type_Declaration then
+               Error_Msg_N
+                 ("\possible interpretation"
+                   & " (inherited, with implicit 'Access) #", N);
+            else
+               Error_Msg_N
+                 ("\possible interpretation (with implicit 'Access) #", N);
+            end if;
+
+         elsif not Access_Formal and then Access_Actual then
+            if Nkind (Parent (Op)) = N_Full_Type_Declaration then
+               Error_Msg_N
+                 ("\possible interpretation"
+                   & " ( inherited, with implicit dereference) #", N);
+            else
+               Error_Msg_N
+                 ("\possible interpretation (with implicit dereference) #", N);
+            end if;
+
+         else
+            if Nkind (Parent (Op)) = N_Full_Type_Declaration then
+               Error_Msg_N ("\possible interpretation (inherited)#", N);
+            else
+               Error_Msg_N ("\possible interpretation#", N);
+            end if;
+         end if;
+      end Report_Ambiguity;
+
       --------------------------------
       -- Transform_Object_Operation --
       --------------------------------
 
       procedure Transform_Object_Operation
         (Call_Node       : out Node_Id;
-         Node_To_Replace : out Node_Id;
-         Subprog         : Node_Id)
+         Node_To_Replace : out Node_Id)
       is
          Parent_Node : constant Node_Id := Parent (N);
 
@@ -5252,13 +5415,13 @@ package body Sem_Ch4 is
             if Nkind (Parent_Node) = N_Procedure_Call_Statement then
                Call_Node :=
                  Make_Procedure_Call_Statement (Loc,
-                   Name => New_Copy_Tree (Subprog),
+                   Name => New_Copy (Subprog),
                    Parameter_Associations => Actuals);
 
             else
                Call_Node :=
                  Make_Function_Call (Loc,
-                   Name => New_Copy_Tree (Subprog),
+                   Name => New_Copy (Subprog),
                    Parameter_Associations => Actuals);
 
             end if;
@@ -5283,7 +5446,7 @@ package body Sem_Ch4 is
 
             Call_Node :=
                Make_Function_Call (Loc,
-                 Name => New_Copy_Tree (Subprog),
+                 Name => New_Copy (Subprog),
                  Parameter_Associations => Actuals);
 
          --  Parameterless call:  Obj.F is rewritten as F (Obj)
@@ -5293,7 +5456,7 @@ package body Sem_Ch4 is
 
             Call_Node :=
                Make_Function_Call (Loc,
-                 Name => New_Copy_Tree (Subprog),
+                 Name => New_Copy (Subprog),
                  Parameter_Associations => New_List (Dummy));
          end if;
       end Transform_Object_Operation;
@@ -5307,19 +5470,40 @@ package body Sem_Ch4 is
          Node_To_Replace : Node_Id) return Boolean
       is
          Anc_Type    : Entity_Id;
+         Matching_Op : Entity_Id := Empty;
+         Error       : Boolean;
+
+         procedure Traverse_Homonyms
+           (Anc_Type : Entity_Id;
+            Error    : out Boolean);
+         --  Traverse the homonym chain of the subprogram searching for those
+         --  homonyms whose first formal has the Anc_Type's class-wide type,
+         --  or an anonymous access type designating the class-wide type. If an
+         --  ambiguity is detected, then Error is set to True.
+
+         procedure Traverse_Interfaces
+           (Anc_Type : Entity_Id;
+            Error    : out Boolean);
+         --  Traverse the list of interfaces, if any, associated with Anc_Type
+         --  and search for acceptable class-wide homonyms associated with each
+         --  interface. If an ambiguity is detected, then Error is set to True.
+
+         -----------------------
+         -- Traverse_Homonyms --
+         -----------------------
+
+         procedure Traverse_Homonyms
+           (Anc_Type : Entity_Id;
+            Error    : out Boolean)
+         is
             Cls_Type    : Entity_Id;
             Hom         : Entity_Id;
             Hom_Ref     : Node_Id;
             Success     : Boolean;
 
          begin
-         --  Loop through ancestor types, traverse the homonym chain of the
-         --  subprogram, and try out those homonyms whose first formal has the
-         --  class-wide type of the ancestor, or an access type to it.
-
-         Anc_Type := Obj_Type;
+            Error := False;
 
-         loop
             Cls_Type := Class_Wide_Type (Anc_Type);
 
             Hom := Current_Entity (Subprog);
@@ -5334,9 +5518,17 @@ package body Sem_Ch4 is
                      or else
                        (Is_Access_Type (Etype (First_Formal (Hom)))
                           and then
+                            Ekind (Etype (First_Formal (Hom))) =
+                              E_Anonymous_Access_Type
+                          and then
                             Designated_Type (Etype (First_Formal (Hom))) =
                                                                    Cls_Type))
                then
+                  Set_Etype (Call_Node, Any_Type);
+                  Set_Is_Overloaded (Call_Node, False);
+                  Success := False;
+
+                  if No (Matching_Op) then
                      Hom_Ref := New_Reference_To (Hom, Sloc (Subprog));
                      Set_Etype (Call_Node, Any_Type);
                      Set_Parent (Call_Node, Parent (Node_To_Replace));
@@ -5350,33 +5542,164 @@ package body Sem_Ch4 is
                         Success    => Success,
                         Skip_First => True);
 
-                  if Success then
-
-                     --  Reformat into the proper call
+                     Matching_Op :=
+                       Valid_Candidate (Success, Call_Node, Hom);
 
-                     Complete_Object_Operation
-                       (Call_Node       => Call_Node,
-                        Node_To_Replace => Node_To_Replace,
-                        Subprog         => Hom_Ref);
+                  else
+                     Analyze_One_Call
+                       (N          => Call_Node,
+                        Nam        => Hom,
+                        Report     => Report_Error,
+                        Success    => Success,
+                        Skip_First => True);
 
-                     return True;
+                     if Present (Valid_Candidate (Success, Call_Node, Hom))
+                       and then Nkind (Call_Node) /= N_Function_Call
+                     then
+                        Error_Msg_NE ("ambiguous call to&", N, Hom);
+                        Report_Ambiguity (Matching_Op);
+                        Report_Ambiguity (Hom);
+                        Error := True;
+                        return;
+                     end if;
                   end if;
                end if;
 
                Hom := Homonym (Hom);
             end loop;
+         end Traverse_Homonyms;
+
+         -------------------------
+         -- Traverse_Interfaces --
+         -------------------------
+
+         procedure Traverse_Interfaces
+           (Anc_Type : Entity_Id;
+            Error    : out Boolean)
+         is
+            Intface      : Node_Id;
+            Intface_List : constant List_Id :=
+                             Abstract_Interface_List (Anc_Type);
+
+         begin
+            Error := False;
+
+            if Is_Non_Empty_List (Intface_List) then
+               Intface := First (Intface_List);
+               while Present (Intface) loop
+
+                  --  Look for acceptable class-wide homonyms associated with
+                  --  the interface.
+
+                  Traverse_Homonyms (Etype (Intface), Error);
+
+                  if Error then
+                     return;
+                  end if;
+
+                  --  Continue the search by looking at each of the interface's
+                  --  associated interface ancestors.
+
+                  Traverse_Interfaces (Etype (Intface), Error);
+
+                  if Error then
+                     return;
+                  end if;
+
+                  Next (Intface);
+               end loop;
+            end if;
+         end Traverse_Interfaces;
+
+      --  Start of processing for Try_Class_Wide_Operation
+
+      begin
+         --  Loop through ancestor types (including interfaces), traversing the
+         --  homonym chain of the subprogram, and trying out those homonyms
+         --  whose first formal has the class-wide type of the ancestor, or an
+         --  anonymous access type designating the class-wide type.
+
+         Anc_Type := Obj_Type;
+         loop
+            --  Look for a match among homonyms associated with the ancestor
+
+            Traverse_Homonyms (Anc_Type, Error);
 
-            --  Examine other ancestor types
+            if Error then
+               return True;
+            end if;
+
+            --  Continue the search for matches among homonyms associated with
+            --  any interfaces implemented by the ancestor.
+
+            Traverse_Interfaces (Anc_Type, Error);
+
+            if Error then
+               return True;
+            end if;
 
             exit when Etype (Anc_Type) = Anc_Type;
             Anc_Type := Etype (Anc_Type);
          end loop;
 
-         --  Nothing matched
+         if Present (Matching_Op) then
+            Set_Etype (Call_Node, Etype (Matching_Op));
+         end if;
 
-         return False;
+         return Present (Matching_Op);
       end Try_Class_Wide_Operation;
 
+      -----------------------------------
+      -- Try_One_Prefix_Interpretation --
+      -----------------------------------
+
+      procedure Try_One_Prefix_Interpretation (T : Entity_Id) is
+      begin
+         Obj_Type := T;
+
+         if Is_Access_Type (Obj_Type) then
+            Obj_Type := Designated_Type (Obj_Type);
+         end if;
+
+         if Ekind (Obj_Type) = E_Private_Subtype then
+            Obj_Type := Base_Type (Obj_Type);
+         end if;
+
+         if Is_Class_Wide_Type (Obj_Type) then
+            Obj_Type := Etype (Class_Wide_Type (Obj_Type));
+         end if;
+
+         --  The type may have be obtained through a limited_with clause,
+         --  in which case the primitive operations are available on its
+         --  non-limited view.
+
+         if Ekind (Obj_Type) = E_Incomplete_Type
+           and then From_With_Type (Obj_Type)
+         then
+            Obj_Type := Non_Limited_View (Obj_Type);
+         end if;
+
+         --  If the object is not tagged, or the type is still an incomplete
+         --  type, this is not a prefixed call.
+
+         if not Is_Tagged_Type (Obj_Type)
+           or else Is_Incomplete_Type (Obj_Type)
+         then
+            return;
+         end if;
+
+         if Try_Primitive_Operation
+              (Call_Node       => New_Call_Node,
+               Node_To_Replace => Node_To_Replace)
+           or else
+             Try_Class_Wide_Operation
+               (Call_Node       => New_Call_Node,
+                Node_To_Replace => Node_To_Replace)
+         then
+            null;
+         end if;
+      end Try_One_Prefix_Interpretation;
+
       -----------------------------
       -- Try_Primitive_Operation --
       -----------------------------
@@ -5387,9 +5710,15 @@ package body Sem_Ch4 is
       is
          Elmt        : Elmt_Id;
          Prim_Op     : Entity_Id;
+         Matching_Op : Entity_Id := Empty;
          Prim_Op_Ref : Node_Id   := Empty;
+
+         Corr_Type   : Entity_Id := Empty;
+         --  If the prefix is a synchronized type, the controlling type of
+         --  the primitive operation is the corresponding record type, else
+         --  this is the object type itself.
+
          Success     : Boolean   := False;
-         Op_Exists   : Boolean := False;
 
          function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
          --  Verify that the prefix, dereferenced if need be, is a valid
@@ -5404,39 +5733,42 @@ package body Sem_Ch4 is
             Typ : constant Entity_Id := Etype (First_Formal (Op));
 
          begin
-            --  Simple case. Object may be a subtype of the tagged type.
+            --  Simple case. Object may be a subtype of the tagged type
+            --  or may be the corresponding record of a synchronized type.
 
             return Obj_Type = Typ
               or else  Base_Type (Obj_Type) = Typ
 
+              or else Corr_Type = Typ
+
                --  Prefix can be dereferenced
 
               or else
-                (Is_Access_Type (Obj_Type)
-                  and then Designated_Type (Obj_Type) = Typ)
+                (Is_Access_Type (Corr_Type)
+                  and then Designated_Type (Corr_Type) = Typ)
 
                --  Formal is an access parameter, for which the object
                --  can provide an access.
 
               or else
                 (Ekind (Typ) = E_Anonymous_Access_Type
-                  and then Designated_Type (Typ) = Base_Type (Obj_Type));
+                  and then Designated_Type (Typ) = Base_Type (Corr_Type));
          end Valid_First_Argument_Of;
 
       --  Start of processing for Try_Primitive_Operation
 
       begin
-         --  Look for subprograms in the list of primitive operations
-         --  The name must be identical, and the kind of call indicates the
-         --  expected kind of operation (function or procedure).
-         --  If the type is a (tagged) synchronized type, the primitive ops
-         --  are attached to the corresponding record type.
+         --  Look for subprograms in the list of primitive operations The name
+         --  must be identical, and the kind of call indicates the expected
+         --  kind of operation (function or procedure). If the type is a
+         --  (tagged) synchronized type, the primitive ops are attached to
+         --  the corresponding record type.
 
          if Is_Concurrent_Type (Obj_Type) then
-            Elmt :=
-              First_Elmt
-               (Primitive_Operations (Corresponding_Record_Type (Obj_Type)));
+            Corr_Type := Corresponding_Record_Type (Obj_Type);
+            Elmt := First_Elmt (Primitive_Operations (Corr_Type));
          else
+            Corr_Type := Obj_Type;
             Elmt := First_Elmt (Primitive_Operations (Obj_Type));
          end if;
 
@@ -5456,21 +5788,31 @@ package body Sem_Ch4 is
                --  primitive is also in this list of primitive operations and
                --  will be used instead.
 
-               if Present (Abstract_Interface_Alias (Prim_Op))
+               if (Present (Abstract_Interface_Alias (Prim_Op))
                      and then Is_Ancestor (Find_Dispatching_Type
-                                         (Alias (Prim_Op)), Obj_Type)
+                                             (Alias (Prim_Op)), Corr_Type))
+                 or else
+
+               --  Do not consider hidden primitives unless they belong to a
+               --  generic private type with a tagged parent.
+
+                  (Is_Hidden (Prim_Op)
+                     and then not Is_Immediately_Visible (Obj_Type))
                then
                   goto Continue;
                end if;
 
-               if not Success then
+               Set_Etype (Call_Node, Any_Type);
+               Set_Is_Overloaded (Call_Node, False);
+
+               if No (Matching_Op) then
                   Prim_Op_Ref := New_Reference_To (Prim_Op, Sloc (Subprog));
                   Candidate := Prim_Op;
 
-                  Set_Etype (Call_Node, Any_Type);
                   Set_Parent (Call_Node, Parent (Node_To_Replace));
 
                   Set_Name (Call_Node, Prim_Op_Ref);
+                  Success := False;
 
                   Analyze_One_Call
                     (N          => Call_Node,
@@ -5479,18 +5821,29 @@ package body Sem_Ch4 is
                      Success    => Success,
                      Skip_First => True);
 
-                  if Success
-                    or else Needs_One_Actual (Prim_Op)
-                  then
-                     Op_Exists := True;
-                  end if;
+                  Matching_Op := Valid_Candidate (Success, Call_Node, Prim_Op);
 
                else
 
                   --  More than one interpretation, collect for subsequent
-                  --  disambiguation.
+                  --  disambiguation. If this is a procedure call and there
+                  --  is another match, report ambiguity now.
+
+                  Analyze_One_Call
+                    (N          => Call_Node,
+                     Nam        => Prim_Op,
+                     Report     => Report_Error,
+                     Success    => Success,
+                     Skip_First => True);
 
-                  Add_One_Interp (Prim_Op_Ref, Prim_Op, Etype (Prim_Op));
+                  if Present (Valid_Candidate (Success, Call_Node, Prim_Op))
+                    and then Nkind (Call_Node) /= N_Function_Call
+                  then
+                     Error_Msg_NE ("ambiguous call to&", N, Prim_Op);
+                     Report_Ambiguity (Matching_Op);
+                     Report_Ambiguity (Prim_Op);
+                     return True;
+                  end if;
                end if;
             end if;
 
@@ -5498,46 +5851,19 @@ package body Sem_Ch4 is
             Next_Elmt (Elmt);
          end loop;
 
-         if Op_Exists then
-            Complete_Object_Operation
-              (Call_Node       => Call_Node,
-               Node_To_Replace => Node_To_Replace,
-               Subprog         => Prim_Op_Ref);
+         if Present (Matching_Op) then
+            Set_Etype (Call_Node, Etype (Matching_Op));
          end if;
 
-         return Op_Exists;
+         return Present (Matching_Op);
       end Try_Primitive_Operation;
 
    --  Start of processing for Try_Object_Operation
 
    begin
-      if Is_Access_Type (Obj_Type) then
-         Obj_Type := Designated_Type (Obj_Type);
-      end if;
-
-      if Ekind (Obj_Type) = E_Private_Subtype then
-         Obj_Type := Base_Type (Obj_Type);
-      end if;
-
-      if Is_Class_Wide_Type (Obj_Type) then
-         Obj_Type := Etype (Class_Wide_Type (Obj_Type));
-      end if;
-
-      --  The type may have be obtained through a limited_with clause,
-      --  in which case the primitive operations are available on its
-      --  non-limited view.
-
-      if Ekind (Obj_Type) = E_Incomplete_Type
-        and then From_With_Type (Obj_Type)
-      then
-         Obj_Type := Non_Limited_View (Obj_Type);
-      end if;
-
-      if not Is_Tagged_Type (Obj_Type) then
-         return False;
-      end if;
+      Analyze_Expression (Obj);
 
-      --  Analyze the actuals if node is know to be a subprogram call
+      --  Analyze the actuals if node is known to be a subprogram call
 
       if Is_Subprg_Call and then N = Name (Parent (N)) then
          Actual := First (Parameter_Associations (Parent (N)));
@@ -5547,29 +5873,38 @@ package body Sem_Ch4 is
          end loop;
       end if;
 
-      Analyze_Expression (Obj);
-
       --  Build a subprogram call node, using a copy of Obj as its first
       --  actual. This is a placeholder, to be replaced by an explicit
       --  dereference when needed.
 
       Transform_Object_Operation
         (Call_Node       => New_Call_Node,
-         Node_To_Replace => Node_To_Replace,
-         Subprog         => Subprog);
+         Node_To_Replace => Node_To_Replace);
 
       Set_Etype (New_Call_Node, Any_Type);
+      Set_Etype (Subprog, Any_Type);
       Set_Parent (New_Call_Node, Parent (Node_To_Replace));
 
-      if Try_Primitive_Operation
-          (Call_Node       => New_Call_Node,
-           Node_To_Replace => Node_To_Replace)
+      if not Is_Overloaded (Obj) then
+         Try_One_Prefix_Interpretation (Obj_Type);
 
-        or else
-          Try_Class_Wide_Operation
+      else
+         declare
+            I  : Interp_Index;
+            It : Interp;
+         begin
+            Get_First_Interp (Obj, I, It);
+            while Present (It.Nam) loop
+               Try_One_Prefix_Interpretation (It.Typ);
+               Get_Next_Interp (I, It);
+            end loop;
+         end;
+      end if;
+
+      if Etype (New_Call_Node) /= Any_Type then
+         Complete_Object_Operation
            (Call_Node       => New_Call_Node,
-             Node_To_Replace => Node_To_Replace)
-      then
+            Node_To_Replace => Node_To_Replace);
          return True;
 
       elsif Present (Candidate) then

gcc/ada/sem_ch6.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- --
@@ -163,7 +163,7 @@ package body Sem_Ch6 is
       Err  : out Boolean;
       Proc : Entity_Id := Empty);
    --  Called to check for missing return statements in a function body, or for
-   --  returns present in a procedure body which has No_Return set. L is the
+   --  returns present in a procedure body which has No_Return set. HSS is the
    --  handled statement sequence for the subprogram body. This procedure
    --  checks all flow paths to make sure they either have return (Mode = 'F',
    --  used for functions) or do not have a return (Mode = 'P', used for
@@ -286,7 +286,7 @@ package body Sem_Ch6 is
       --  return.
 
       if Nkind (N) = N_Extended_Return_Statement then
-         New_Scope (Stm_Entity);
+         Push_Scope (Stm_Entity);
       end if;
 
       --  Check that pragma No_Return is obeyed:
@@ -526,11 +526,11 @@ package body Sem_Ch6 is
 
          R_Stm_Type_Is_Anon_Access :
            constant Boolean :=
-             Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
+             Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
                or else
-             Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
+             Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
                or else
-             Ekind (R_Type) = E_Anonymous_Access_Type;
+             Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
          --  True if type of the return object is an anonymous access type
 
       begin
@@ -545,10 +545,15 @@ package body Sem_Ch6 is
 
          if R_Type_Is_Anon_Access then
             if R_Stm_Type_Is_Anon_Access then
-               if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
+               if Base_Type (Designated_Type (R_Stm_Type)) /=
+                    Base_Type (Designated_Type (R_Type))
+                 or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
+               then
                   Error_Msg_N
-                    ("subtypes must statically match", Subtype_Ind);
+                    ("subtype must statically match function result subtype",
+                     Subtype_Mark (Subtype_Ind));
                end if;
+
             else
                Error_Msg_N ("must use anonymous access type", Subtype_Ind);
             end if;
@@ -560,10 +565,30 @@ package body Sem_Ch6 is
             if Is_Constrained (R_Type) then
                if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
                   Error_Msg_N
-                    ("subtypes must statically match", Subtype_Ind);
+                    ("subtype must statically match function result subtype",
+                     Subtype_Ind);
                end if;
             end if;
 
+         --  If the function's result type doesn't match the return object
+         --  entity's type, then we check for the case where the result type
+         --  is class-wide, and allow the declaration if the type of the object
+         --  definition matches the class-wide type. This prevents rejection
+         --  in the case where the object declaration is initialized by a call
+         --  to a build-in-place function with a specific result type and the
+         --  object entity had its type changed to that specific type. (Note
+         --  that the ARG believes that return objects should be allowed to
+         --  have a type covered by a class-wide result type in any case, so
+         --  once that relaxation is made (see AI05-32), the above check for
+         --  type compatibility should be changed to test Covers rather than
+         --  equality, and then the following special test will no longer be
+         --  needed. ???)
+
+         elsif Is_Class_Wide_Type (R_Type)
+           and then R_Type = Etype (Object_Definition (Obj_Decl))
+         then
+            null;
+
          else
             Error_Msg_N
               ("wrong type for return_subtype_indication", Subtype_Ind);
@@ -742,7 +767,7 @@ package body Sem_Ch6 is
       --  needed to process the formals declarations. Then make the formals
       --  visible in a separate step.
 
-      New_Scope (Gen_Id);
+      Push_Scope (Gen_Id);
 
       declare
          E         : Entity_Id;
@@ -1265,6 +1290,11 @@ package body Sem_Ch6 is
             Set_Etype (Designator, Typ);
 
             if Ekind (Typ) = E_Incomplete_Type
+              and then Is_Value_Type (Typ)
+            then
+               null;
+
+            elsif Ekind (Typ) = E_Incomplete_Type
               or else (Is_Class_Wide_Type (Typ)
                          and then
                            Ekind (Root_Type (Typ)) = E_Incomplete_Type)
@@ -1801,7 +1831,7 @@ package body Sem_Ch6 is
 
             Install_Formals (Spec_Id);
             Last_Formal := Last_Entity (Spec_Id);
-            New_Scope (Spec_Id);
+            Push_Scope (Spec_Id);
 
             --  Make sure that the subprogram is immediately visible. For
             --  child units that have no separate spec this is indispensable.
@@ -1835,12 +1865,12 @@ package body Sem_Ch6 is
               (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
             Generate_Reference_To_Formals (Body_Id);
             Install_Formals (Body_Id);
-            New_Scope (Body_Id);
+            Push_Scope (Body_Id);
          end if;
       end if;
 
       --  Ada 2005 (AI-251): Check wrong placement of abstract interface
-      --  primitives.
+      --  primitives, and update anonymous access returns with limited views.
 
       if Ada_Version >= Ada_05
         and then Comes_From_Source (N)
@@ -1848,6 +1878,7 @@ package body Sem_Ch6 is
          declare
             E    : Entity_Id;
             Etyp : Entity_Id;
+            Rtyp : Entity_Id;
 
          begin
             --  Check the type of the formals
@@ -1891,6 +1922,24 @@ package body Sem_Ch6 is
                      " defined in package specs", N);
                end if;
             end if;
+
+            --  If the return type is an anonymous access type whose
+            --  designated type is the limited view of a class-wide type
+            --  and the non-limited view is available. update the return
+            --  type accordingly.
+
+            Rtyp := Etype (Current_Scope);
+
+            if Ekind (Rtyp) = E_Anonymous_Access_Type then
+               Etyp := Directly_Designated_Type (Rtyp);
+
+               if Is_Class_Wide_Type (Etyp)
+                 and then From_With_Type (Etyp)
+               then
+                  Set_Directly_Designated_Type
+                    (Etype (Current_Scope), Available_View (Etyp));
+               end if;
+            end if;
          end;
       end if;
 
@@ -2060,12 +2109,15 @@ package body Sem_Ch6 is
          Stm : Node_Id := First (Statements (HSS));
 
       begin
-         --  Skip an initial label (for one thing this occurs when we are in
-         --  front end ZCX mode, but in any case it is irrelevant).
+         --  Skip initial labels (for one thing this occurs when we are in
+         --  front end ZCX mode, but in any case it is irrelevant), and also
+         --  initial Push_xxx_Error_Label nodes, which are also irrelevant.
 
-         if Nkind (Stm) = N_Label then
+         while Nkind (Stm) = N_Label
+           or else Nkind (Stm) in N_Push_xxx_Label
+         loop
             Next (Stm);
-         end if;
+         end loop;
 
          --  Do the test on the original statement before expansion
 
@@ -2165,9 +2217,9 @@ package body Sem_Ch6 is
    begin
       Generate_Definition (Designator);
 
-      --  Check for RCI unit subprogram declarations against in-lined
+      --  Check for RCI unit subprogram declarations for illegal inlined
       --  subprograms and subprograms having access parameter or limited
-      --  parameter without Read and Write (RM E.2.3(12-13)).
+      --  parameter without Read and Write attributes (RM E.2.3(12-13)).
 
       Validate_RCI_Subprogram_Declaration (N);
 
@@ -2249,7 +2301,7 @@ package body Sem_Ch6 is
       else
          --  For a compilation unit, check for library-unit pragmas
 
-         New_Scope (Designator);
+         Push_Scope (Designator);
          Set_Categorization_From_Pragmas (N);
          Validate_Categorization_Dependency (N, Designator);
          Pop_Scope;
@@ -2299,6 +2351,8 @@ package body Sem_Ch6 is
 
    function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
       Designator : constant Entity_Id := Defining_Entity (N);
+      Formal     : Entity_Id;
+      Formal_Typ : Entity_Id;
       Formals    : constant List_Id   := Parameter_Specifications (N);
 
    --  Start of processing for Analyze_Subprogram_Specification
@@ -2321,30 +2375,31 @@ package body Sem_Ch6 is
       Set_Scope (Designator, Current_Scope);
 
       if Present (Formals) then
-         New_Scope (Designator);
+         Push_Scope (Designator);
          Process_Formals (Formals, N);
 
-         --  Ada 2005 (AI-345): Allow overriding primitives of protected
-         --  interfaces by means of normal subprograms. For this purpose
-         --  temporarily use the corresponding record type as the etype
-         --  of the first formal.
+         --  Ada 2005 (AI-345): Allow the overriding of interface primitives
+         --  by subprograms which belong to a concurrent type implementing an
+         --  interface. Set the parameter type of each controlling formal to
+         --  the corresponding record type.
 
-         if Ada_Version >= Ada_05
-           and then Comes_From_Source (Designator)
-           and then Present (First_Entity (Designator))
-           and then (Ekind (Etype (First_Entity (Designator)))
-                             = E_Protected_Type
-                       or else
-                     Ekind (Etype (First_Entity (Designator)))
-                             = E_Task_Type)
-           and then Present (Corresponding_Record_Type
-                             (Etype (First_Entity (Designator))))
+         if Ada_Version >= Ada_05 then
+            Formal := First_Formal (Designator);
+            while Present (Formal) loop
+               Formal_Typ := Etype (Formal);
+
+               if (Ekind (Formal_Typ) = E_Protected_Type
+                     or else Ekind (Formal_Typ) = E_Task_Type)
+                 and then Present (Corresponding_Record_Type (Formal_Typ))
                  and then Present (Abstract_Interfaces
-                             (Corresponding_Record_Type
-                             (Etype (First_Entity (Designator)))))
+                                  (Corresponding_Record_Type (Formal_Typ)))
                then
-            Set_Etype (First_Entity (Designator),
-              Corresponding_Record_Type (Etype (First_Entity (Designator))));
+                  Set_Etype (Formal,
+                    Corresponding_Record_Type (Formal_Typ));
+               end if;
+
+               Formal := Next_Formal (Formal);
+            end loop;
          end if;
 
          End_Scope;
@@ -2657,6 +2712,7 @@ package body Sem_Ch6 is
       begin
          return Check_All_Returns (N) = OK
            and then Present (Declarations (N))
+           and then Present (First (Declarations (N)))
            and then Chars (Expression (Return_Statement)) =
                     Chars (Defining_Identifier (First (Declarations (N))));
       end Has_Single_Return;
@@ -2836,7 +2892,7 @@ package body Sem_Ch6 is
       Remove_Pragmas;
 
       Analyze (Body_To_Analyze);
-      New_Scope (Defining_Entity (Body_To_Analyze));
+      Push_Scope (Defining_Entity (Body_To_Analyze));
       Save_Global_References (Original_Body);
       End_Scope;
       Remove (Body_To_Analyze);
@@ -2987,7 +3043,7 @@ package body Sem_Ch6 is
          end if;
 
          --  Ada 2005 (AI-231): In case of anonymous access types check the
-         --  null-exclusion and access-to-constant attributes must match.
+         --  null-exclusion and access-to-constant attributes match.
 
          if Ada_Version >= Ada_05
            and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
@@ -3010,7 +3066,7 @@ package body Sem_Ch6 is
          return;
       end if;
 
-      --  In subtype conformant case, conventions must match (RM 6.3.1(16))
+      --  In subtype conformant case, conventions must match (RM 6.3.1(16)).
       --  If this is a renaming as body, refine error message to indicate that
       --  the conflict is with the original declaration. If the entity is not
       --  frozen, the conventions don't have to match, the one of the renamed
@@ -3161,13 +3217,7 @@ package body Sem_Ch6 is
             return;
          end if;
 
-         --  Full conformance checks
-
-         if Ctype = Fully_Conformant then
-
-            --  We have checked already that names match
-
-            if Parameter_Mode (Old_Formal) = E_In_Parameter then
+         if Ctype >= Subtype_Conformant then
 
             --  Ada 2005 (AI-231): In case of anonymous access types check
             --  the null-exclusion and access-to-constant attributes must
@@ -3175,25 +3225,21 @@ package body Sem_Ch6 is
 
             if Ada_Version >= Ada_05
               and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
+              and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type
               and then
-                   (Can_Never_Be_Null (Old_Formal)
-                      /= Can_Never_Be_Null (New_Formal)
-                    or else Is_Access_Constant (Etype (Old_Formal))
-                              /= Is_Access_Constant (Etype (New_Formal)))
+                (Can_Never_Be_Null (Old_Formal) /=
+                 Can_Never_Be_Null (New_Formal)
+                   or else
+                 Is_Access_Constant (Etype (Old_Formal)) /=
+                 Is_Access_Constant (Etype (New_Formal)))
             then
-                  --  It is allowed to omit the null-exclusion in case of
-                  --  stream attribute subprograms
+               --  It is allowed to omit the null-exclusion in case of stream
+               --  attribute subprograms. We recognize stream subprograms
+               --  through their TSS-generated suffix.
 
                declare
-                     TSS_Name : TSS_Name_Type;
-
+                  TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id);
                begin
-                     Get_Name_String (Chars (New_Id));
-                     TSS_Name :=
-                       TSS_Name_Type
-                         (Name_Buffer
-                            (Name_Len - TSS_Name'Length + 1 .. Name_Len));
-
                   if TSS_Name /= TSS_Stream_Read
                     and then TSS_Name /= TSS_Stream_Write
                     and then TSS_Name /= TSS_Stream_Input
@@ -3205,6 +3251,15 @@ package body Sem_Ch6 is
                   end if;
                end;
             end if;
+         end if;
+
+         --  Full conformance checks
+
+         if Ctype = Fully_Conformant then
+
+            --  We have checked already that names match
+
+            if Parameter_Mode (Old_Formal) = E_In_Parameter then
 
                --  Check default expressions for in parameters
 
@@ -3218,12 +3273,11 @@ package body Sem_Ch6 is
 
                      --  The old default value has been analyzed because the
                      --  current full declaration will have frozen everything
-                     --  before. The new default values have not been
-                     --  analyzed, so analyze them now before we check for
-                     --  conformance.
+                     --  before. The new default value has not been analyzed,
+                     --  so analyze it now before we check for conformance.
 
                      if NewD then
-                        New_Scope (New_Id);
+                        Push_Scope (New_Id);
                         Analyze_Per_Use_Expression
                           (Default_Value (New_Formal), Etype (New_Formal));
                         End_Scope;
@@ -3245,7 +3299,7 @@ package body Sem_Ch6 is
          end if;
 
          --  A couple of special checks for Ada 83 mode. These checks are
-         --  skipped if either entity is an operator in package Standard.
+         --  skipped if either entity is an operator in package Standard,
          --  or if either old or new instance is not from the source program.
 
          if Ada_Version = Ada_83
@@ -3274,7 +3328,7 @@ package body Sem_Ch6 is
                --  Grouping (use of comma in param lists) must be the same
                --  This is where we catch a misconformance like:
 
-               --    A,B : Integer
+               --    A, B : Integer
                --    A : Integer; B : Integer
 
                --  which are represented identically in the tree except
@@ -3313,14 +3367,22 @@ package body Sem_Ch6 is
    -----------------------
 
    procedure Check_Conventions (Typ : Entity_Id) is
+
+      function Skip_Check (Op : Entity_Id) return Boolean;
+      pragma Inline (Skip_Check);
+      --  A small optimization: skip the predefined dispatching operations,
+      --  since they always have the same convention. Also do not consider
+      --  abstract primitives since those are left by an erroneous overriding.
+      --  This function returns True for any operation that is thus exempted
+      --  exempted from checking.
+
       procedure Check_Convention
         (Op          : Entity_Id;
          Search_From : Elmt_Id);
-      --  Verify that the convention of inherited dispatching operation
-      --  Op is consistent among all subprograms it overrides. In order
-      --  to minimize the search, Search_From is utilized to designate
-      --  a specific point in the list rather than iterating over the
-      --  whole list once more.
+      --  Verify that the convention of inherited dispatching operation Op is
+      --  consistent among all subprograms it overrides. In order to minimize
+      --  the search, Search_From is utilized to designate a specific point in
+      --  the list rather than iterating over the whole list once more.
 
       ----------------------
       -- Check_Convention --
@@ -3331,8 +3393,8 @@ package body Sem_Ch6 is
          Search_From : Elmt_Id)
       is
          procedure Error_Msg_Operation (Op : Entity_Id);
-         --  Emit a continuation to an error message depicting the kind,
-         --  name, convention and source location of subprogram Op.
+         --  Emit a continuation to an error message depicting the kind, name,
+         --  convention and source location of subprogram Op.
 
          -------------------------
          -- Error_Msg_Operation --
@@ -3343,9 +3405,8 @@ package body Sem_Ch6 is
             Error_Msg_Name_1 := Chars (Op);
 
             --  Error messages of primitive subprograms do not contain a
-            --  convention attribute since the convention may have been
-            --  first inherited from a parent subprogram, then changed by
-            --  a pragma.
+            --  convention attribute since the convention may have been first
+            --  inherited from a parent subprogram, then changed by a pragma.
 
             if Comes_From_Source (Op) then
                Error_Msg_Sloc := Sloc (Op);
@@ -3370,42 +3431,46 @@ package body Sem_Ch6 is
 
          --  Local variables
 
-         Prim_Op      : Entity_Id;
-         Prim_Op_Elmt : Elmt_Id;
+         Second_Prim_Op      : Entity_Id;
+         Second_Prim_Op_Elmt : Elmt_Id;
 
       --  Start of processing for Check_Convention
 
       begin
-         Prim_Op_Elmt := Next_Elmt (Search_From);
-         while Present (Prim_Op_Elmt) loop
-            Prim_Op := Node (Prim_Op_Elmt);
-
-            --  A small optimization, skip the predefined dispatching
-            --  operations since they always have the same convention.
-            --  Also do not consider abstract primitives since those
-            --  are left by an erroneous overriding.
+         Second_Prim_Op_Elmt := Next_Elmt (Search_From);
+         while Present (Second_Prim_Op_Elmt) loop
+            Second_Prim_Op := Node (Second_Prim_Op_Elmt);
 
-            if not Is_Predefined_Dispatching_Operation (Prim_Op)
-              and then not Is_Abstract_Subprogram (Prim_Op)
-              and then Chars (Prim_Op) = Chars (Op)
-              and then Type_Conformant (Prim_Op, Op)
-              and then Convention (Prim_Op) /= Convention (Op)
+            if not Skip_Check (Second_Prim_Op)
+              and then Chars (Second_Prim_Op) = Chars (Op)
+              and then Type_Conformant (Second_Prim_Op, Op)
+              and then Convention (Second_Prim_Op) /= Convention (Op)
             then
                Error_Msg_N
                  ("inconsistent conventions in primitive operations", Typ);
 
                Error_Msg_Operation (Op);
-               Error_Msg_Operation (Prim_Op);
+               Error_Msg_Operation (Second_Prim_Op);
 
                --  Avoid cascading errors
 
                return;
             end if;
 
-            Next_Elmt (Prim_Op_Elmt);
+            Next_Elmt (Second_Prim_Op_Elmt);
          end loop;
       end Check_Convention;
 
+      ----------------
+      -- Skip_Check --
+      ----------------
+
+      function Skip_Check (Op : Entity_Id) return Boolean is
+      begin
+         return Is_Predefined_Dispatching_Operation (Op)
+           or else Is_Abstract_Subprogram (Op);
+      end Skip_Check;
+
       --  Local variables
 
       Prim_Op      : Entity_Id;
@@ -3414,21 +3479,19 @@ package body Sem_Ch6 is
    --  Start of processing for Check_Conventions
 
    begin
-      --  The algorithm checks every overriding dispatching operation
-      --  against all the corresponding overridden dispatching operations,
-      --  detecting differences in coventions.
+      --  The algorithm checks every overriding dispatching operation against
+      --  all the corresponding overridden dispatching operations, detecting
+      --  differences in coventions.
 
       Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ));
       while Present (Prim_Op_Elmt) loop
          Prim_Op := Node (Prim_Op_Elmt);
 
-         --  A small optimization, skip the predefined dispatching operations
+         --  A small optimization: skip the predefined dispatching operations
          --  since they always have the same convention. Also avoid processing
          --  of abstract primitives left from an erroneous overriding.
 
-         if not Is_Predefined_Dispatching_Operation (Prim_Op)
-           and then not Is_Abstract_Subprogram (Prim_Op)
-         then
+         if not Skip_Check (Prim_Op) then
             Check_Convention
               (Op          => Prim_Op,
                Search_From => Prim_Op_Elmt);
@@ -3792,6 +3855,13 @@ package body Sem_Ch6 is
    -- Check_Returns --
    -------------------
 
+   --  Note: this procedure needs to know far too much about how the expander
+   --  messes with exceptions. The use of the flag Exception_Junk and the
+   --  incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
+   --  works, but is not very clean. It would be better if the expansion
+   --  routines would leave Original_Node working nicely, and we could use
+   --  Original_Node here to ignore all the peculiar expander messing ???
+
    procedure Check_Returns
      (HSS  : Node_Id;
       Mode : Character;
@@ -3811,6 +3881,7 @@ package body Sem_Ch6 is
 
       procedure Check_Statement_Sequence (L : List_Id) is
          Last_Stm : Node_Id;
+         Stm      : Node_Id;
          Kind     : Node_Kind;
 
          Raise_Exception_Call : Boolean;
@@ -3824,6 +3895,65 @@ package body Sem_Ch6 is
 
          Last_Stm := Last (L);
 
+         --  Deal with digging out exception handler statement sequences that
+         --  have been transformed by the local raise to goto optimization.
+         --  See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
+         --  optimization has occurred, we are looking at something like:
+
+         --  begin
+         --     original stmts in block
+
+         --  exception            \
+         --     when excep1 =>     |
+         --        goto L1;        | omitted if No_Exception_Propagation
+         --     when excep2 =>     |
+         --        goto L2;       /
+         --  end;
+
+         --  goto L3;      -- skip handler when exception not raised
+
+         --  <<L1>>        -- target label for local exception
+         --     begin
+         --        estmts1
+         --     end;
+
+         --     goto L3;
+
+         --  <<L2>>
+         --     begin
+         --        estmts2
+         --     end;
+
+         --  <<L3>>
+
+         --  and what we have to do is to dig out the estmts1 and estmts2
+         --  sequences (which were the original sequences of statements in
+         --  the exception handlers) and check them.
+
+         if Nkind (Last_Stm) = N_Label
+           and then Exception_Junk (Last_Stm)
+         then
+            Stm := Last_Stm;
+            loop
+               Prev (Stm);
+               exit when No (Stm);
+               exit when Nkind (Stm) /= N_Block_Statement;
+               exit when not Exception_Junk (Stm);
+               Prev (Stm);
+               exit when No (Stm);
+               exit when Nkind (Stm) /= N_Label;
+               exit when not Exception_Junk (Stm);
+               Check_Statement_Sequence
+                 (Statements (Handled_Statement_Sequence (Next (Stm))));
+
+               Prev (Stm);
+               Last_Stm := Stm;
+               exit when No (Stm);
+               exit when Nkind (Stm) /= N_Goto_Statement;
+               exit when not Exception_Junk (Stm);
+            end loop;
+         end if;
+
          --  Don't count pragmas
 
          while Nkind (Last_Stm) = N_Pragma
@@ -3844,6 +3974,8 @@ package body Sem_Ch6 is
                  or else Nkind (Last_Stm) = N_Label
                  or else Nkind (Last_Stm) = N_Object_Declaration)
                 and then Exception_Junk (Last_Stm))
+           or else Nkind (Last_Stm) in N_Push_xxx_Label
+           or else Nkind (Last_Stm) in N_Pop_xxx_Label
          loop
             Prev (Last_Stm);
          end loop;
@@ -4236,13 +4368,20 @@ package body Sem_Ch6 is
       Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
 
       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
-      --  If neither T1 nor T2 are generic actual types, or if they are
-      --  in different scopes (e.g. parent and child instances), then verify
-      --  that the base types are equal. Otherwise T1 and T2 must be
-      --  on the same subtype chain. The whole purpose of this procedure
-      --  is to prevent spurious ambiguities in an instantiation that may
-      --  arise if two distinct generic types are instantiated with the
-      --  same actual.
+      --  If neither T1 nor T2 are generic actual types, or if they are in
+      --  different scopes (e.g. parent and child instances), then verify that
+      --  the base types are equal. Otherwise T1 and T2 must be on the same
+      --  subtype chain. The whole purpose of this procedure is to prevent
+      --  spurious ambiguities in an instantiation that may arise if two
+      --  distinct generic types are instantiated with the same actual.
+
+      function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
+      --  Returns True if and only if either T1 denotes a limited view of T2
+      --  or T2 denotes a limited view of T1. This can arise when the limited
+      --  with view of a type is used in a subprogram declaration and the
+      --  subprogram body is in the scope of a regular with clause for the
+      --  same unit. In such a case, the two type entities can be considered
+      --  identical for purposes of conformance checking.
 
       ----------------------
       -- Base_Types_Match --
@@ -4255,7 +4394,7 @@ package body Sem_Ch6 is
 
          elsif Base_Type (T1) = Base_Type (T2) then
 
-            --  The following is too permissive. A more precise test must
+            --  The following is too permissive. A more precise test should
             --  check that the generic actual is an ancestor subtype of the
             --  other ???.
 
@@ -4263,27 +4402,36 @@ package body Sem_Ch6 is
               or else not Is_Generic_Actual_Type (T2)
               or else Scope (T1) /= Scope (T2);
 
-         --  In some cases a type imported through a limited_with clause,
-         --  and its non-limited view are both visible, for example in an
-         --  anonymous access_to_classwide type in a formal. Both entities
-         --  designate the same type.
+         else
+            return False;
+         end if;
+      end Base_Types_Match;
+
+      -------------------------------
+      -- Matches_Limited_With_View --
+      -------------------------------
+
+      function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is
+      begin
+         --  In some cases a type imported through a limited_with clause, and
+         --  its nonlimited view are both visible, for example in an anonymous
+         --  access-to-class-wide type in a formal. Both entities designate the
+         --  same type.
 
-         elsif From_With_Type (T1)
-           and then Ekind (T1) = E_Incomplete_Type
-           and then T2 = Non_Limited_View (T1)
+         if From_With_Type (T1)
+           and then T2 = Available_View (T1)
          then
             return True;
 
          elsif From_With_Type (T2)
-           and then Ekind (T2) = E_Incomplete_Type
-           and then T1 = Non_Limited_View (T2)
+           and then T1 = Available_View (T2)
          then
             return True;
 
          else
             return False;
          end if;
-      end Base_Types_Match;
+      end Matches_Limited_With_View;
 
    --  Start of processing for Conforming_Types
 
@@ -4298,9 +4446,13 @@ package body Sem_Ch6 is
          Type_2 := Get_Instance_Of (T2);
       end if;
 
-      --  First see if base types match
+      --  If one of the types is a view of the other introduced by a limited
+      --  with clause, treat these as conforming for all purposes.
+
+      if Matches_Limited_With_View (T1, T2) then
+         return True;
 
-      if Base_Types_Match (Type_1, Type_2) then
+      elsif Base_Types_Match (Type_1, Type_2) then
          return Ctype <= Mode_Conformant
            or else Subtypes_Statically_Match (Type_1, Type_2);
 
@@ -4327,7 +4479,7 @@ package body Sem_Ch6 is
            or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
       end if;
 
-      --  Ada 2005 (AI-254): Anonymous access to subprogram types must be
+      --  Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
       --  treated recursively because they carry a signature.
 
       Are_Anonymous_Access_To_Subprogram_Types :=
@@ -4587,7 +4739,12 @@ package body Sem_Ch6 is
             end if;
          end if;
 
-         --  Create extra formal for supporting accessibility checking
+         --  Create extra formal for supporting accessibility checking. This
+         --  is done for both anonymous access formals and formals of named
+         --  access types that are marked as controlling formals. The latter
+         --  case can occur when Expand_Dispatching_Call creates a subprogram
+         --  type and substitutes the types of access-to-class-wide actuals
+         --  for the anonymous access-to-specific-type of controlling formals.
 
          --  This is suppressed if we specifically suppress accessibility
          --  checks at the package level for either the subprogram, or the
@@ -4597,7 +4754,9 @@ package body Sem_Ch6 is
          --  different suppression setting. The explicit checks at the
          --  package level are safe from this point of view.
 
-         if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+         if (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+              or else (Is_Controlling_Formal (Formal)
+                        and then Is_Access_Type (Etype (Formal))))
            and then not
              (Explicit_Suppress (E, Accessibility_Check)
                or else
@@ -4648,10 +4807,15 @@ package body Sem_Ch6 is
             --  allocated by the caller (0), or should be allocated by the
             --  callee on the secondary stack (1) or in the global heap (2).
             --  For the moment we just use Natural for the type of this formal.
-            --  Note that this formal isn't needed in the case where the
-            --  result subtype is constrained.
+            --  Note that this formal isn't usually needed in the case where
+            --  the result subtype is constrained, but it is needed when the
+            --  function has a tagged result, because generally such functions
+            --  can be called in a dispatching context and such calls must be
+            --  handled like calls to a class-wide function.
 
-            if not Is_Constrained (Result_Subt) then
+            if not Is_Constrained (Result_Subt)
+              or else Is_Tagged_Type (Underlying_Type (Result_Subt))
+            then
                Discard :=
                  Add_Extra_Formal
                    (E, Standard_Natural,
@@ -4669,10 +4833,13 @@ package body Sem_Ch6 is
             --  region, rather than using copy-back after the function
             --  returns. This is true even if we are able to get away with
             --  having 'in out' parameters, which are normally illegal for
-            --  functions.
+            --  functions. This formal is also needed when the function has
+            --  a tagged result, because generally such functions can be called
+            --  in a dispatching context and such calls must be handled like
+            --  calls to class-wide functions.
 
-            if Is_Controlled (Result_Subt)
-              or else Has_Controlled_Component (Result_Subt)
+            if Controlled_Type (Result_Subt)
+              or else Is_Tagged_Type (Underlying_Type (Result_Subt))
             then
                Discard :=
                  Add_Extra_Formal
@@ -5027,7 +5194,7 @@ package body Sem_Ch6 is
    begin
       --  Non-conformant if paren count does not match. Note: if some idiot
       --  complains that we don't do this right for more than 3 levels of
-      --  parentheses, they will be treated with the respect they deserve :-)
+      --  parentheses, they will be treated with the respect they deserve!
 
       if Paren_Count (E1) /= Paren_Count (E2) then
          return False;
@@ -5767,6 +5934,7 @@ package body Sem_Ch6 is
          First_Hom       : Entity_Id;
          Overridden_Subp : out Entity_Id)
       is
+         Formal_Typ  : Entity_Id;
          Ifaces_List : Elist_Id;
          In_Scope    : Boolean;
          Typ         : Entity_Id;
@@ -5783,8 +5951,9 @@ package body Sem_Ch6 is
             return;
          end if;
 
-         --  Def_Id must be declared withing the scope of a protected or
-         --  task type or be a primitive operation of such a type.
+         --  Search for the concurrent declaration since it contains the list
+         --  of all implemented interfaces. In this case, the subprogram is
+         --  declared within the scope of a protected or a task type.
 
          if Present (Scope (Def_Id))
            and then Is_Concurrent_Type (Scope (Def_Id))
@@ -5793,27 +5962,49 @@ package body Sem_Ch6 is
             Typ := Scope (Def_Id);
             In_Scope := True;
 
-         elsif Present (First_Formal (Def_Id))
-           and then Is_Concurrent_Type (Etype (First_Formal (Def_Id)))
-           and then not Is_Generic_Actual_Type (Etype (First_Formal (Def_Id)))
+         --  The subprogram may be a primitive of a concurrent type
+
+         elsif Present (First_Formal (Def_Id)) then
+            Formal_Typ := Etype (First_Formal (Def_Id));
+
+            if Is_Concurrent_Type (Formal_Typ)
+              and then not Is_Generic_Actual_Type (Formal_Typ)
             then
-            Typ := Etype (First_Formal (Def_Id));
+               Typ := Formal_Typ;
+               In_Scope := False;
+
+            --  This case occurs when the concurrent type is declared within
+            --  a generic unit. As a result the corresponding record has been
+            --  built and used as the type of the first formal, we just have
+            --  to retrieve the corresponding concurrent type.
+
+            elsif Is_Concurrent_Record_Type (Formal_Typ)
+              and then Present (Corresponding_Concurrent_Type (Formal_Typ))
+            then
+               Typ := Corresponding_Concurrent_Type (Formal_Typ);
                In_Scope := False;
 
             else
                return;
             end if;
+         else
+            return;
+         end if;
 
          --  Gather all limited, protected and task interfaces that Typ
-         --  implements. Do not collect the interfaces in case of full type
-         --  declarations because they don't have interface lists.
+         --  implements. There is no overriding to check if is an inherited
+         --  operation in a type derivation on for a generic actual.
 
-         if Nkind (Parent (Typ)) /= N_Full_Type_Declaration then
+         if Nkind (Parent (Typ)) /= N_Full_Type_Declaration
+           and then Nkind (Parent (Def_Id)) /= N_Subtype_Declaration
+           and then Nkind (Parent (Def_Id)) /= N_Task_Type_Declaration
+           and then Nkind (Parent (Def_Id)) /= N_Protected_Type_Declaration
+         then
             Collect_Abstract_Interfaces (Typ, Ifaces_List);
 
             if not Is_Empty_Elmt_List (Ifaces_List) then
                Overridden_Subp :=
-                 Overrides_Synchronized_Primitive
+                 Find_Overridden_Synchronized_Primitive
                    (Def_Id, First_Hom, Ifaces_List, In_Scope);
             end if;
          end if;
@@ -6538,10 +6729,23 @@ package body Sem_Ch6 is
                if Is_Tagged_Type (Formal_Type) then
                   null;
 
+               --  Special handling of Value_Type for CIL case
+
+               elsif Is_Value_Type (Formal_Type) then
+                  null;
+
                elsif Nkind (Parent (T)) /= N_Access_Function_Definition
                  and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
                then
                   Error_Msg_N ("invalid use of incomplete type", Param_Spec);
+
+               --  An incomplete type that is not tagged is allowed in an
+               --  access-to-subprogram type only if it is a local declaration
+               --  with a forthcoming completion (3.10.1 (9.2/2)).
+
+               elsif Scope (Formal_Type) /= Scope (Current_Scope) then
+                  Error_Msg_N
+                    ("invalid use of limited view of type", Param_Spec);
                end if;
 
             elsif Ekind (Formal_Type) = E_Void then
@@ -6558,15 +6762,17 @@ package body Sem_Ch6 is
               and then Null_Exclusion_Present (Param_Spec)
             then
                if not Is_Access_Type (Formal_Type) then
-                  Error_Msg_N ("null-exclusion must be applied to an " &
-                               "access type", Param_Spec);
+                  Error_Msg_N
+                    ("`NOT NULL` allowed only for an access type", Param_Spec);
+
                else
                   if Can_Never_Be_Null (Formal_Type)
                     and then Comes_From_Source (Related_Nod)
                   then
-                     Error_Msg_N
-                       ("null-exclusion cannot be applied to " &
-                        "a null excluding type", Param_Spec);
+                     Error_Msg_NE
+                       ("`NOT NULL` not allowed (& already excludes null)",
+                        Param_Spec,
+                        Formal_Type);
                   end if;
 
                   Formal_Type :=
@@ -6574,6 +6780,18 @@ package body Sem_Ch6 is
                       (T           => Formal_Type,
                        Related_Nod => Related_Nod,
                        Scope_Id    => Scope (Current_Scope));
+
+                  --  If the designated type of the itype is an itype we
+                  --  decorate it with the Has_Delayed_Freeze attribute to
+                  --  avoid problems with the backend.
+
+                  --  Example:
+                  --     type T is access procedure;
+                  --     procedure Op (O : not null T);
+
+                  if Is_Itype (Directly_Designated_Type (Formal_Type)) then
+                     Set_Has_Delayed_Freeze (Formal_Type);
+                  end if;
                end if;
             end if;
 
@@ -6702,10 +6920,12 @@ package body Sem_Ch6 is
          return;
       end if;
 
+      --  Iterate over both lists. They may be of different lengths if the two
+      --  specs are not conformant.
+
       Fs := First_Formal (Spec);
       Fb := First_Formal (Bod);
-
-      while Present (Fs) loop
+      while Present (Fs) and then Present (Fb) loop
          Generate_Reference (Fs, Fb, 'b');
 
          if Style_Check then

gcc/ada/sem_type.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- --
@@ -167,9 +167,9 @@ package body Sem_Type is
    --  multiple interpretations. Interpretations can be added to only one
    --  node at a time.
 
-   function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
-   --  If T1 and T2 are compatible, return  the one that is not
-   --  universal or is not a "class" type (any_character,  etc).
+   function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
+   --  If Typ_1 and Typ_2 are compatible, return the one that is not universal
+   --  or is not a "class" type (any_character, etc).
 
    --------------------
    -- Add_One_Interp --
@@ -344,6 +344,7 @@ package body Sem_Type is
            or else Nkind (N) = N_Expanded_Name
            or else (Nkind (N) in N_Op and then E = Entity (N))
            or else In_Instance
+           or else Ekind (Vis_Type) = E_Anonymous_Access_Type
          then
             null;
 
@@ -1332,9 +1333,9 @@ package body Sem_Type is
                   elsif Present (Act2)
                     and then Nkind (Act2) in N_Op
                     and then Is_Overloaded (Act2)
-                    and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
+                    and then (Nkind (Right_Opnd (Act2)) = N_Integer_Literal
                                 or else
-                              Nkind (Right_Opnd (Act1)) = N_Real_Literal)
+                              Nkind (Right_Opnd (Act2)) = N_Real_Literal)
                     and then Has_Compatible_Type (Act2, Standard_Boolean)
                   then
                      --  The preference rule on the first actual is not
@@ -1451,6 +1452,19 @@ package body Sem_Type is
          end if;
       end if;
 
+      --  Check for overloaded CIL convention stuff because the CIL libraries
+      --  do sick things like Console.WriteLine where it matches
+      --  two different overloads, so just pick the first ???
+
+      if Convention (Nam1) = Convention_CIL
+        and then Convention (Nam2) = Convention_CIL
+        and then Ekind (Nam1) = Ekind (Nam2)
+        and then (Ekind (Nam1) = E_Procedure
+                   or else Ekind (Nam1) = E_Function)
+      then
+         return It2;
+      end if;
+
       --  If the context is universal, the predefined operator is preferred.
       --  This includes bounds in numeric type declarations, and expressions
       --  in type conversions. If no interpretation yields a universal type,
@@ -1869,14 +1883,19 @@ package body Sem_Type is
       --  is no rule in 4.6 that allows "access Integer" to be converted to P.
 
       elsif Ada_Version >= Ada_05
-        and then Ekind (Etype (L)) = E_Anonymous_Access_Type
+        and then
+          (Ekind (Etype (L)) = E_Anonymous_Access_Type
+             or else
+           Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type)
         and then Is_Access_Type (Etype (R))
         and then Ekind (Etype (R)) /= E_Access_Type
       then
          return Etype (L);
 
       elsif Ada_Version >= Ada_05
-        and then Ekind (Etype (R)) = E_Anonymous_Access_Type
+        and then
+          (Ekind (Etype (R)) = E_Anonymous_Access_Type
+            or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
         and then Is_Access_Type (Etype (L))
         and then Ekind (Etype (L)) /= E_Access_Type
       then
@@ -2058,17 +2077,22 @@ package body Sem_Type is
       Iface : Entity_Id) return Boolean
    is
       Target_Typ : Entity_Id;
+      Iface_Typ  : Entity_Id;
 
       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
       --  Returns True if Typ or some ancestor of Typ implements Iface
 
+      -------------------------------
+      -- Iface_Present_In_Ancestor --
+      -------------------------------
+
       function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
          E    : Entity_Id;
          AI   : Entity_Id;
          Elmt : Elmt_Id;
 
       begin
-         if Typ = Iface then
+         if Typ = Iface_Typ then
             return True;
          end if;
 
@@ -2091,7 +2115,7 @@ package body Sem_Type is
                while Present (Elmt) loop
                   AI := Node (Elmt);
 
-                  if AI = Iface or else Is_Ancestor (Iface, AI) then
+                  if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
                      return True;
                   end if;
 
@@ -2109,7 +2133,7 @@ package body Sem_Type is
             --  Check if the current type is a direct derivation of the
             --  interface
 
-            if Etype (E) = Iface then
+            if Etype (E) = Iface_Typ then
                return True;
             end if;
 
@@ -2128,6 +2152,16 @@ package body Sem_Type is
    --  Start of processing for Interface_Present_In_Ancestor
 
    begin
+      if Is_Class_Wide_Type (Iface) then
+         Iface_Typ := Etype (Iface);
+      else
+         Iface_Typ := Iface;
+      end if;
+
+      --  Handle subtypes
+
+      Iface_Typ := Base_Type (Iface_Typ);
+
       if Is_Access_Type (Typ) then
          Target_Typ := Etype (Directly_Designated_Type (Typ));
       else
@@ -2138,20 +2172,22 @@ package body Sem_Type is
          Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
       end if;
 
+      Target_Typ := Base_Type (Target_Typ);
+
       --  In case of concurrent types we can't use the Corresponding Record_Typ
       --  to look for the interface because it is built by the expander (and
       --  hence it is not always available). For this reason we traverse the
       --  list of interfaces (available in the parent of the concurrent type)
 
       if Is_Concurrent_Type (Target_Typ) then
-         if Present (Interface_List (Parent (Base_Type (Target_Typ)))) then
+         if Present (Interface_List (Parent (Target_Typ))) then
             declare
                AI : Node_Id;
 
             begin
-               AI := First (Interface_List (Parent (Base_Type (Target_Typ))));
+               AI := First (Interface_List (Parent (Target_Typ)));
                while Present (AI) loop
-                  if Etype (AI) = Iface then
+                  if Etype (AI) = Iface_Typ then
                      return True;
 
                   elsif Present (Abstract_Interfaces (Etype (AI)))
@@ -2674,7 +2710,9 @@ package body Sem_Type is
    -- Specific_Type --
    -------------------
 
-   function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
+   function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
+      T1 : constant Entity_Id := Available_View (Typ_1);
+      T2 : constant Entity_Id := Available_View (Typ_2);
       B1 : constant Entity_Id := Base_Type (T1);
       B2 : constant Entity_Id := Base_Type (T2);
 

gcc/ada/sem_type.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- --
@@ -207,8 +207,9 @@ package Sem_Type is
      (Typ   : Entity_Id;
       Iface : Entity_Id) return Boolean;
    --  Ada 2005 (AI-251): Typ must be a tagged record type/subtype and Iface
-   --  must be an abstract interface type. This function is used to check if
-   --  Typ or some ancestor of Typ implements Iface.
+   --  must be an abstract interface type (or a class-wide abstract interface).
+   --  This function is used to check if Typ or some ancestor of Typ implements
+   --  Iface (returning True only if so).
 
    function Intersect_Types (L, R : Node_Id) return Entity_Id;
    --  Find the common interpretation to two analyzed nodes. If one of the