From f1668c3d35b1031fa3ee266b6c3292e53344d315 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Sun, 16 Oct 2022 19:48:53 +0000 Subject: ada: Enforce matching of extra formals This patch enforces matching of extra formals in overridden subprograms, subprogram renamings, and subprograms to which attributes 'Access, 'Unchecked_Access, or 'Unrestricted_Access is applied (for these access cases the subprogram is checked against its corresponding subprogram type). This enforcement is an internal consistency check, not an implementation of some language legality rule. gcc/ada/ * debug.adb (Debug_Flag_Underscore_XX): Switch -gnatd_X used temporarily to allow disabling extra formal checks. * exp_attr.adb (Expand_N_Attribute_Reference [access types]): Add extra formals to the subprogram referenced in the prefix of 'Unchecked_Access, 'Unrestricted_Access or 'Access; required to check that its extra formals match the extra formals of the corresponding subprogram type. * exp_ch3.adb (Stream_Operation_OK): Declaration moved to the public part of the package. (Validate_Tagged_Type_Extra_Formals): New subprogram. (Expand_Freeze_Record_Type): Improve the code that takes care of adding the extra formals of dispatching primitives; extended to add also the extra formals to renamings of dispatching primitives. * exp_ch3.ads (Stream_Operation_OK): Declaration moved from the package body. * exp_ch6.adb (Check_BIP_Actuals): Complete documentation. (Has_BIP_Extra_Formal): Subprogram declaration moved to the public part of the package. In addition, a parameter has been added to disable an assertion that requires its use with frozen entities. (Duplicate_Params_Without_Extra_Actuals): New subprogram. (Check_Subprogram_Variant): Emit the call without duplicating the extra formals since they will be added when the call is analyzed. (Expand_Call_Helper): Ensure that the called subprogram has all its extra formals, enforce assertion checking extra formals on thunks, and mark calls from thunks as processed-BIP-calls to avoid adding their extra formals twice. (Is_Build_In_Place_Function): Return False for entities with foreign convention. (Is_Build_In_Place_Function_Call): Return True also for not BIP functions that have BIP formals since the extra actuals are required. (Make_Build_In_Place_Call_In_Object_Declaration): Occurrences of Is_Return_Object replaced by the local variable Is_OK_Return_Object that evaluates to False for scopes with foreign convention. (Might_Have_Tasks): Fix check of class-wide limited record types. (Needs_BIP_Task_Actuals): Remove assertion to allow calling this function in more contexts; in addition it returns False for functions returning objects with foreign convention. (Needs_BIP_Finalization_Master): Likewise. (Needs_BIP_Alloc_Form): Likewise. (Validate_Subprogram_Calls): Check that the number of actuals (including extra actuals) of calls in the subtree N match their corresponding formals. * exp_ch6.ads (Has_BIP_Extra_Formal): Subprogram declaration moved to the public part of the package. In addition, a parameter has been added to disable an assertion that requires its use with frozen entities. (Is_Build_In_Place_Function_Call): Complete documentation. (Validate_Subprogram_Calls): Check that the number of actuals (including extra actuals) of calls in the subtree N match their corresponding formals. * freeze.adb (Check_Itype): Add extra formals to anonymous access subprogram itypes. (Freeze_Expression): Improve code that disables the addition of extra formals to functions with foreign convention. (Check_Extra_Formals): Moved to package Sem_Ch6 as Extra_Formals_OK. (Freeze_Subprogram): Add extra formals to non-dispatching subprograms. * frontend.adb (Frontend): Validate all the subprogram calls; it can be disabled using switch -gnatd_X * sem_ch3.adb (Access_Subprogram_Declaration): Defer the addition of extra formals to the freezing point so that we know the convention. (Check_Anonymous_Access_Component): Likewise. (Derive_Subprogram): Fix documentation. * sem_ch6.adb (Has_Reliable_Extra_Formals): New subprogram. (Check_Anonymous_Return): Fix check of access to class-wide limited record types. (Check_Untagged_Equality): Placed in alphabetical order. (Extra_Formals_OK): Subprogram moved from freeze.adb. (Extra_Formals_Match_OK): New subprogram. (Has_BIP_Formals): New subprogram. (Has_Extra_Formals): New subprograms. (Needs_Accessibility_Check_Extra): New subprogram. (Parent_Subprogram): New subprogram. (Add_Extra_Formal): Minor code cleanup. (Create_Extra_Formals): Enforce matching extra formals on overridden and aliased entities. * sem_ch6.ads (Extra_Formals_Match_OK): New subprogram. (Extra_Formals_OK): Subprogram moved from freeze.adb. * sem_eval.adb (Compile_Time_Known_Value): Improve predicate to avoid assertion failure; found working on this ticket; this change does not affect the behavior of the compiler because this subprogram has an exception handler that returns False when the assertion fails. * sem_util.adb (Needs_Result_Accessibility_Level): Do not return False for dispatching operations compiled with Ada_Version < 2012 since they they may be overridden by primitives compiled with Ada_Version >= Ada_2012. --- gcc/ada/exp_ch3.adb | 136 ++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 116 insertions(+), 20 deletions(-) (limited to 'gcc/ada/exp_ch3.adb') diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1e70b584f22..90f01ca2747 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -44,7 +44,6 @@ with Exp_Dist; use Exp_Dist; with Exp_Put_Image; with Exp_Smem; use Exp_Smem; with Exp_Strm; use Exp_Strm; -with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Ghost; use Ghost; @@ -408,15 +407,6 @@ package body Exp_Ch3 is -- Freeze entities of all predefined primitive operations. This is needed -- because the bodies of these operations do not normally do any freezing. - function Stream_Operation_OK - (Typ : Entity_Id; - Operation : TSS_Name_Type) return Boolean; - -- Check whether the named stream operation must be emitted for a given - -- type. The rules for inheritance of stream attributes by type extensions - -- are enforced by this function. Furthermore, various restrictions prevent - -- the generation of these operations, as a useful optimization or for - -- certification purposes and to save unnecessary generated code. - -------------------------- -- Adjust_Discriminants -- -------------------------- @@ -5380,6 +5370,10 @@ package body Exp_Ch3 is procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id); -- Register dispatch-table wrappers in the dispatch table of Typ + procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id); + -- Check extra formals of dispatching primitives of tagged type Typ. + -- Used in pragma Debug. + --------------------------------------- -- Build_Class_Condition_Subprograms -- --------------------------------------- @@ -5509,6 +5503,78 @@ package body Exp_Ch3 is end loop; end Register_Dispatch_Table_Wrappers; + ---------------------------------------- + -- Validate_Tagged_Type_Extra_Formals -- + ---------------------------------------- + + procedure Validate_Tagged_Type_Extra_Formals (Typ : Entity_Id) is + Ovr_Subp : Entity_Id; + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + pragma Assert (not Is_Class_Wide_Type (Typ)); + + -- No check required if expansion is not active since we never + -- generate extra formals in such case. + + if not Expander_Active then + return; + end if; + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Subp := Node (Elmt); + + -- Extra formals of a dispatching primitive must match: + + -- 1) The extra formals of its covered interface primitive + + if Present (Interface_Alias (Subp)) then + pragma Assert + (Extra_Formals_Match_OK + (E => Interface_Alias (Subp), + Ref_E => Alias (Subp))); + end if; + + -- 2) The extra formals of its renamed primitive + + if Present (Alias (Subp)) then + pragma Assert + (Extra_Formals_Match_OK + (E => Subp, + Ref_E => Ultimate_Alias (Subp))); + end if; + + -- 3) The extra formals of its overridden primitive + + if Present (Overridden_Operation (Subp)) then + Ovr_Subp := Overridden_Operation (Subp); + + -- Handle controlling function wrapper + + if Is_Wrapper (Subp) + and then Ultimate_Alias (Ovr_Subp) = Subp + then + if Present (Overridden_Operation (Ovr_Subp)) then + pragma Assert + (Extra_Formals_Match_OK + (E => Subp, + Ref_E => Overridden_Operation (Ovr_Subp))); + end if; + + else + pragma Assert + (Extra_Formals_Match_OK + (E => Subp, + Ref_E => Ovr_Subp)); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end Validate_Tagged_Type_Extra_Formals; + -- Local variables Typ : constant Node_Id := Entity (N); @@ -5897,28 +5963,58 @@ package body Exp_Ch3 is -- inherited functions, then add their bodies to the freeze actions. Append_Freeze_Actions (Typ, Wrapper_Body_List); + end if; - -- Create extra formals for the primitive operations of the type. - -- This must be done before analyzing the body of the initialization - -- procedure, because a self-referential type might call one of these - -- primitives in the body of the init_proc itself. + -- Create extra formals for the primitive operations of the type. + -- This must be done before analyzing the body of the initialization + -- procedure, because a self-referential type might call one of these + -- primitives in the body of the init_proc itself. + -- + -- This is not needed: + -- 1) If expansion is disabled, because extra formals are only added + -- when we are generating code. + -- + -- 2) For types with foreign convention since primitives with foreign + -- convention don't have extra formals and AI95-117 requires that + -- all primitives of a tagged type inherit the convention. + if Expander_Active + and then Is_Tagged_Type (Typ) + and then not Has_Foreign_Convention (Typ) + then declare Elmt : Elmt_Id; - Subp : Entity_Id; + E : Entity_Id; begin + -- Add extra formals to primitive operations + Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Elmt) loop - Subp := Node (Elmt); - if not Has_Foreign_Convention (Subp) - and then not Is_Predefined_Dispatching_Operation (Subp) + Create_Extra_Formals (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + + -- Add extra formals to renamings of primitive operations. The + -- addition of extra formals is done in two steps to minimize + -- the compile time required for this action; the evaluation of + -- Find_Dispatching_Type() and Contains() is only done here for + -- renamings that are not primitive operations. + + E := First_Entity (Scope (Typ)); + while Present (E) loop + if Is_Dispatching_Operation (E) + and then Present (Alias (E)) + and then Find_Dispatching_Type (E) = Typ + and then not Contains (Primitive_Operations (Typ), E) then - Create_Extra_Formals (Subp); + Create_Extra_Formals (E); end if; - Next_Elmt (Elmt); + Next_Entity (E); end loop; + + pragma Debug (Validate_Tagged_Type_Extra_Formals (Typ)); end; end if; -- cgit v1.2.1