diff options
Diffstat (limited to 'gcc/ada/exp_ch3.adb')
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 92 |
1 files changed, 92 insertions, 0 deletions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 45d5baf..418306f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -26,6 +26,7 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; +with Contracts; use Contracts; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -5352,10 +5353,66 @@ package body Exp_Ch3 is ------------------------------- procedure Expand_Freeze_Record_Type (N : Node_Id) is + + procedure Build_Class_Condition_Subprograms (Typ : Entity_Id); + -- Create internal subprograms of Typ primitives that have class-wide + -- preconditions or postconditions; they are invoked by the caller to + -- evaluate the conditions. + procedure Build_Variant_Record_Equality (Typ : Entity_Id); -- Create An Equality function for the untagged variant record Typ and -- attach it to the TSS list. + procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id); + -- Register dispatch-table wrappers in the dispatch table of Typ + + --------------------------------------- + -- Build_Class_Condition_Subprograms -- + --------------------------------------- + + procedure Build_Class_Condition_Subprograms (Typ : Entity_Id) is + Prim_List : constant Elist_Id := Primitive_Operations (Typ); + Prim_Elmt : Elmt_Id := First_Elmt (Prim_List); + Prim : Entity_Id; + + begin + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Primitive with class-wide preconditions + + if Comes_From_Source (Prim) + and then Has_Significant_Contract (Prim) + and then + (Present (Class_Preconditions (Prim)) + or else Present (Ignored_Class_Preconditions (Prim))) + then + if Expander_Active then + Make_Class_Precondition_Subps (Prim); + end if; + + -- Wrapper of a primitive that has or inherits class-wide + -- preconditions. + + elsif Is_Primitive_Wrapper (Prim) + and then + (Present (Nearest_Class_Condition_Subprogram + (Spec_Id => Prim, + Kind => Class_Precondition)) + or else + Present (Nearest_Class_Condition_Subprogram + (Spec_Id => Prim, + Kind => Ignored_Class_Precondition))) + then + if Expander_Active then + Make_Class_Precondition_Subps (Prim); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Build_Class_Condition_Subprograms; + ----------------------------------- -- Build_Variant_Record_Equality -- ----------------------------------- @@ -5417,6 +5474,27 @@ package body Exp_Ch3 is end if; end Build_Variant_Record_Equality; + -------------------------------------- + -- Register_Dispatch_Table_Wrappers -- + -------------------------------------- + + procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id) is + Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ)); + Subp : Entity_Id; + + begin + while Present (Elmt) loop + Subp := Node (Elmt); + + if Is_Dispatch_Table_Wrapper (Subp) then + Append_Freeze_Actions (Typ, + Register_Primitive (Sloc (Subp), Subp)); + end if; + + Next_Elmt (Elmt); + end loop; + end Register_Dispatch_Table_Wrappers; + -- Local variables Typ : constant Node_Id := Entity (N); @@ -5666,6 +5744,13 @@ package body Exp_Ch3 is if not Building_Static_DT (Typ) then Append_Freeze_Actions (Typ, Make_DT (Typ)); + + -- Register dispatch table wrappers in the dispatch table. + -- It could not be done when these wrappers were built + -- because, at that stage, the dispatch table was not + -- available. + + Register_Dispatch_Table_Wrappers (Typ); end if; end if; @@ -5857,6 +5942,13 @@ package body Exp_Ch3 is end loop; end; end if; + + -- Build internal subprograms of primitives with class-wide + -- pre/postconditions. + + if Is_Tagged_Type (Typ) then + Build_Class_Condition_Subprograms (Typ); + end if; end Expand_Freeze_Record_Type; ------------------------------------ |