diff options
Diffstat (limited to 'gcc/ada/exp_ch3.adb')
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 129 |
1 files changed, 20 insertions, 109 deletions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 30ec739..0d82691 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -44,6 +44,7 @@ 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; @@ -407,6 +408,15 @@ 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 -- -------------------------- @@ -5369,10 +5379,6 @@ 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 -- --------------------------------------- @@ -5502,71 +5508,6 @@ 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 primitive must match 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))); - - elsif 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 => Overridden_Operation (Subp))); - end if; - - elsif Present (Alias (Subp)) then - pragma Assert - (Extra_Formals_Match_OK - (E => Subp, - Ref_E => Ultimate_Alias (Subp))); - end if; - - Next_Elmt (Elmt); - end loop; - end Validate_Tagged_Type_Extra_Formals; - -- Local variables Typ : constant Node_Id := Entity (N); @@ -5955,58 +5896,28 @@ 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. - -- - -- 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 AI-117 requires that all - -- primitives of a tagged type inherit the convention. + -- 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. - if Expander_Active - and then Is_Tagged_Type (Typ) - and then not Has_Foreign_Convention (Typ) - then declare Elmt : Elmt_Id; - E : Entity_Id; + Subp : Entity_Id; begin - -- Add extra formals to primitive operations - Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Elmt) loop - 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) + Subp := Node (Elmt); + if not Has_Foreign_Convention (Subp) + and then not Is_Predefined_Dispatching_Operation (Subp) then - Create_Extra_Formals (E); + Create_Extra_Formals (Subp); end if; - Next_Entity (E); + Next_Elmt (Elmt); end loop; - - pragma Debug (Validate_Tagged_Type_Extra_Formals (Typ)); end; end if; |