[Ada] Wrappers of access-to-subprograms with pre/post conditions

gcc/ada/

	* sem_ch3.adb (Build_Access_Subprogram_Wrapper): Decorate the
	wrapper with attribute Is_Wrapper, and move its declaration to
	the freezing actions of its type declaration; done to facilitate
	identifying it at later stages to avoid handling it as a
	primitive operation of a tagged type; otherwise it may be
	handled as a dispatching operation and erroneously registered in
	a dispatch table.
	(Make_Index): Add missing decoration of field Parent.
	* sem_disp.adb (Check_Dispatching_Operation): Complete
	decoration of late-overriding dispatching primitives.
	(Is_Access_To_Subprogram_Wrapper): New subprogram.
	(Inherited_Subprograms): Prevent cascaded errors; adding missing
	support for private types.
	* sem_type.adb (Add_One_Interp): Add missing support for the
	first interpretation of a primitive of an inmediate ancestor
	interface.
	* sem_util.adb (Check_Result_And_Post_State_In_Pragma): Do not
	report missing reference in postcondition placed in internally
	built wrappers.
	* exp_disp.adb (Expand_Dispatching_Call): Adding assertion.

1 files changed, 70 insertions, 0 deletions

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 064e2b5..cc612db 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -1018,6 +1018,9 @@ package body Sem_Disp is
    ---------------------------------
 
    procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
+      function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean;
+      --  Return True if E is an access to subprogram wrapper
+
       procedure Warn_On_Late_Primitive_After_Private_Extension
         (Typ  : Entity_Id;
          Prim : Entity_Id);
@@ -1025,6 +1028,22 @@ package body Sem_Disp is
       --  if it is a public primitive defined after some private extension of
       --  the tagged type.
 
+      -------------------------------------
+      -- Is_Access_To_Subprogram_Wrapper --
+      -------------------------------------
+
+      function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean
+      is
+         Decl_N : constant Node_Id := Unit_Declaration_Node (E);
+         Par_N  : constant Node_Id := Parent (List_Containing (Decl_N));
+
+      begin
+         --  Access to subprogram wrappers are declared in the freezing actions
+
+         return Nkind (Par_N) = N_Freeze_Entity
+           and then Ekind (Entity (Par_N)) = E_Access_Subprogram_Type;
+      end Is_Access_To_Subprogram_Wrapper;
+
       ----------------------------------------------------
       -- Warn_On_Late_Primitive_After_Private_Extension --
       ----------------------------------------------------
@@ -1095,6 +1114,13 @@ package body Sem_Disp is
         or else Is_Partial_Invariant_Procedure (Subp)
       then
          return;
+
+      --  Wrappers of access to subprograms are not primitive subprograms.
+
+      elsif Is_Wrapper (Subp)
+        and then Is_Access_To_Subprogram_Wrapper (Subp)
+      then
+         return;
       end if;
 
       Set_Is_Dispatching_Operation (Subp, False);
@@ -1407,6 +1433,35 @@ package body Sem_Disp is
                            Generate_Reference (Tagged_Type, Subp, 'P', False);
                            Override_Dispatching_Operation
                              (Tagged_Type, Old_Subp, Subp);
+                           Set_Is_Dispatching_Operation (Subp);
+
+                           --  Inherit decoration of controlling formals and
+                           --  controlling result.
+
+                           if Ekind (Old_Subp) = E_Function
+                             and then Has_Controlling_Result (Old_Subp)
+                           then
+                              Set_Has_Controlling_Result (Subp);
+                           end if;
+
+                           if Present (First_Formal (Old_Subp)) then
+                              declare
+                                 Old_Formal : Entity_Id;
+                                 Formal     : Entity_Id;
+
+                              begin
+                                 Formal     := First_Formal (Subp);
+                                 Old_Formal := First_Formal (Old_Subp);
+
+                                 while Present (Old_Formal) loop
+                                    Set_Is_Controlling_Formal (Formal,
+                                      Is_Controlling_Formal (Old_Formal));
+
+                                    Next_Formal (Formal);
+                                    Next_Formal (Old_Formal);
+                                 end loop;
+                              end;
+                           end if;
                         end if;
                      end if;
                   end if;
@@ -2420,12 +2475,27 @@ package body Sem_Disp is
 
                   if No (Tag_Typ) then
                      return Result (1 .. 0);
+
+                  --  Prevent cascaded errors
+
+                  elsif Is_Concurrent_Type (Tag_Typ)
+                     and then No (Corresponding_Record_Type (Tag_Typ))
+                     and then Serious_Errors_Detected > 0
+                  then
+                     return Result (1 .. 0);
                   end if;
 
                   if Is_Concurrent_Type (Tag_Typ) then
                      Tag_Typ := Corresponding_Record_Type (Tag_Typ);
                   end if;
 
+                  if Present (Tag_Typ)
+                    and then Is_Private_Type (Tag_Typ)
+                    and then Present (Full_View (Tag_Typ))
+                  then
+                     Tag_Typ := Full_View (Tag_Typ);
+                  end if;
+
                   --  Search primitive operations of dispatching type
 
                   if Present (Tag_Typ)