diff options
Diffstat (limited to 'gcc/ada/exp_disp.adb')
| -rw-r--r-- | gcc/ada/exp_disp.adb | 87 |
1 files changed, 28 insertions, 59 deletions
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 080a2e1..619ac40 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -801,7 +801,7 @@ package body Exp_Disp is -- No action needed if the dispatching call has been already expanded - or else Is_Expanded_Dispatching_Call (Name (Call_Node)) + or else Is_Expanded_Dispatching_Call (Call_Node) then return; end if; @@ -926,6 +926,8 @@ package body Exp_Disp is New_Formal : Entity_Id; Last_Formal : Entity_Id := Empty; + use Deferred_Extra_Formals_Support; + begin if Present (Old_Formal) then New_Formal := New_Copy (Old_Formal); @@ -962,51 +964,21 @@ package body Exp_Disp is end if; -- Now that the explicit formals have been duplicated, any extra - -- formals needed by the subprogram must be duplicated; we know - -- that extra formals are available because they were added when - -- the tagged type was frozen (see Expand_Freeze_Record_Type). + -- formals needed by the subprogram must be added; we know that + -- extra formals are available because they were added when the + -- tagged type was frozen (see Expand_Freeze_Record_Type). pragma Assert (Is_Frozen (Typ)); - -- Warning: The addition of the extra formals cannot be performed - -- here invoking Create_Extra_Formals since we must ensure that all - -- the extra formals of the pointer type and the target subprogram - -- match (and for functions that return a tagged type the profile of - -- the built subprogram type always returns a class-wide type, which - -- may affect the addition of some extra formals). - - if Present (Last_Formal) - and then Present (Extra_Formal (Last_Formal)) - then - Old_Formal := Extra_Formal (Last_Formal); - New_Formal := New_Copy (Old_Formal); - Set_Scope (New_Formal, Subp_Typ); - - Set_Extra_Formal (Last_Formal, New_Formal); - Set_Extra_Formals (Subp_Typ, New_Formal); - - if Ekind (Subp) = E_Function - and then Present (Extra_Accessibility_Of_Result (Subp)) - and then Extra_Accessibility_Of_Result (Subp) = Old_Formal - then - Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal); - end if; - - Old_Formal := Extra_Formal (Old_Formal); - while Present (Old_Formal) loop - Set_Extra_Formal (New_Formal, New_Copy (Old_Formal)); - New_Formal := Extra_Formal (New_Formal); - Set_Scope (New_Formal, Subp_Typ); + if Extra_Formals_Known (Subp) then + Create_Extra_Formals (Subp_Typ); - if Ekind (Subp) = E_Function - and then Present (Extra_Accessibility_Of_Result (Subp)) - and then Extra_Accessibility_Of_Result (Subp) = Old_Formal - then - Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal); - end if; + -- Extra formals were previously deferred - Old_Formal := Extra_Formal (Old_Formal); - end loop; + else + pragma Assert (Is_Deferred_Extra_Formals_Entity (Subp)); + Register_Deferred_Extra_Formals_Entity (Subp_Typ); + Register_Deferred_Extra_Formals_Call (Call_Node, Current_Scope); end if; end; @@ -1237,6 +1209,8 @@ package body Exp_Disp is -- the generation of spurious warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); + + Set_Is_Expanded_Dispatching_Call (Call_Node); end Expand_Dispatching_Call; --------------------------------- @@ -2378,17 +2352,6 @@ package body Exp_Disp is and then not Restriction_Active (No_Dispatching_Calls); end Has_DT; - ---------------------------------- - -- Is_Expanded_Dispatching_Call -- - ---------------------------------- - - function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is - begin - return Nkind (N) in N_Subprogram_Call - and then Nkind (Name (N)) = N_Explicit_Dereference - and then Is_Dispatch_Table_Entity (Etype (Name (N))); - end Is_Expanded_Dispatching_Call; - ------------------------------------- -- Is_Predefined_Dispatching_Alias -- ------------------------------------- @@ -8345,13 +8308,15 @@ package body Exp_Disp is Defining_Unit_Name => IP, Parameter_Specifications => Parms))); - Set_Init_Proc (Typ, IP); - Set_Is_Imported (IP); - Set_Is_Constructor (IP); - Set_Interface_Name (IP, Interface_Name (E)); - Set_Convention (IP, Convention_CPP); - Set_Is_Public (IP); - Set_Has_Completion (IP); + Set_Init_Proc (Typ, IP); + Set_Is_Imported (IP); + Set_Is_Constructor (IP); + Set_Interface_Name (IP, Interface_Name (E)); + Set_Convention (IP, Convention_CPP); + Set_Is_Public (IP); + Set_Has_Completion (IP); + Mutate_Ekind (IP, E_Procedure); + Freeze_Extra_Formals (IP); -- Case 2: Constructor of a tagged type @@ -8484,6 +8449,8 @@ package body Exp_Disp is Discard_Node (IP_Body); Set_Init_Proc (Typ, IP); + Mutate_Ekind (IP, E_Procedure); + Freeze_Extra_Formals (IP); end; end if; @@ -8549,6 +8516,8 @@ package body Exp_Disp is Discard_Node (IP_Body); Set_Init_Proc (Typ, IP); + Mutate_Ekind (IP, E_Procedure); + Freeze_Extra_Formals (IP); end; end if; |