This patch fixes decoration of wrappers of access to subprograms with
pre/post conditions (that is, wrappers internally built by the compiler
to support AI12-0220). This patch also adds assertions, fixes node
decorations, and avoids cascade errors.
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
--- 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
--- 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
--- 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
--- 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
--- 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;