From abf3f4f3096dcc95614fdd5c9f6a2351eaaae9df Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Mon, 26 Jul 2021 04:55:39 -0400 Subject: [PATCH] [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. --- gcc/ada/exp_disp.adb | 4 +++ gcc/ada/sem_ch3.adb | 24 +++++++++++++++++- gcc/ada/sem_disp.adb | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_type.adb | 6 +++++ gcc/ada/sem_util.adb | 2 ++ 5 files changed, 105 insertions(+), 1 deletion(-) 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; -- 2.7.4