[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.

5 files changed, 105 insertions, 1 deletions

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index cfe6279..7cce41b 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1016,6 +1016,10 @@ package body Exp_Disp is
 
       Typ := Find_Specific_Type (CW_Typ);
 
+      --  The tagged type of a dispatching call must be frozen at this stage
+
+      pragma Assert (Is_Frozen (Typ));
+
       if not Is_Limited_Type (Typ) then
          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
       end if;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 7ba6f7b..677a9f5 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6767,6 +6767,7 @@ package body Sem_Ch3 is
            Make_Procedure_Specification (Loc,
              Defining_Unit_Name       => Subp,
              Parameter_Specifications => Profile);
+         Mutate_Ekind (Subp, E_Procedure);
       else
          Spec :=
            Make_Function_Specification (Loc,
@@ -6775,13 +6776,32 @@ package body Sem_Ch3 is
              Result_Definition        =>
                New_Copy_Tree
                  (Result_Definition (Type_Definition (Decl))));
+         Mutate_Ekind (Subp, E_Function);
       end if;
 
       New_Decl :=
         Make_Subprogram_Declaration (Loc, Specification => Spec);
       Set_Aspect_Specifications (New_Decl, Contracts);
+      Set_Is_Wrapper (Subp);
+
+      --  The wrapper is declared in the freezing actions to facilitate its
+      --  identification and thus avoid handling it as a primitive operation
+      --  of a tagged type (see Is_Access_To_Subprogram_Wrapper); otherwise it
+      --  may be handled as a dispatching operation and erroneously registered
+      --  in a dispatch table.
+
+      if not GNATprove_Mode then
+         Ensure_Freeze_Node (Id);
+         Append_Freeze_Actions (Id, New_List (New_Decl));
+
+      --  Under GNATprove mode there is no such problem but we do not declare
+      --  it in the freezing actions since they are not analyzed under this
+      --  mode.
+
+      else
+         Insert_After (Decl, New_Decl);
+      end if;
 
-      Insert_After (Decl, New_Decl);
       Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp);
       Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl);
    end Build_Access_Subprogram_Wrapper;
@@ -19794,6 +19814,8 @@ package body Sem_Ch3 is
                Set_Is_Non_Static_Subtype (Def_Id);
             end if;
          end if;
+
+         Set_Parent (Def_Id, N);
       end if;
 
       --  Final step is to label the index with this constructed type
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)
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 825741a..3ca2e30 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -444,6 +444,12 @@ package body Sem_Type is
                    Find_Dispatching_Type (E))
          then
             Add_One_Interp (N, Interface_Alias (E), T);
+
+         --  Otherwise this is the first interpretation, N has type Any_Type
+         --  and we must place the new type on the node.
+
+         else
+            Set_Etype (N, T);
          end if;
 
          return;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4a98b8b..f5cf834 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5012,6 +5012,7 @@ package body Sem_Util is
               and then not Mentions_Post_State (Expr)
               and then not (Is_Ghost_Entity (Subp_Id)
                              and then Has_No_Output (Subp_Id))
+              and then not Is_Wrapper (Subp_Id)
             then
                if Pragma_Name (Prag) = Name_Contract_Cases then
                   Error_Msg_NE (Adjust_Message
@@ -32045,6 +32046,7 @@ package body Sem_Util is
                   end if;
                end;
             end if;
+
             return False;
          end Is_Access_Type_For_Indirect_Temp;