diff options
Diffstat (limited to 'gcc/ada/sem_disp.adb')
| -rw-r--r-- | gcc/ada/sem_disp.adb | 97 |
1 files changed, 71 insertions, 26 deletions
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 29b8e409e21..4c538b0ff40 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -54,7 +54,7 @@ package body Sem_Disp is (Tagged_Type : Entity_Id; Prev_Op : Entity_Id; New_Op : Entity_Id); - -- Replace an implicit dispatching operation with an explicit one. + -- Replace an implicit dispatching operation with an explicit one. -- Prev_Op is an inherited primitive operation which is overridden -- by the explicit declaration of New_Op. @@ -145,7 +145,7 @@ package body Sem_Disp is ("operation can be dispatching in only one type", Subp); end if; - -- Verify that the restriction in E.2.2 (1) is obeyed. + -- Verify that the restriction in E.2.2 (14) is obeyed elsif Remote and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type @@ -274,8 +274,8 @@ package body Sem_Disp is and then not Is_Abstract (Alias (Func)) and then No (DTC_Entity (Func)) then - -- private overriding of inherited abstract operation, - -- call is legal + -- Private overriding of inherited abstract operation, + -- call is legal. Set_Entity (Name (N), Alias (Func)); return; @@ -341,7 +341,7 @@ package body Sem_Disp is if not Is_Controlling_Actual (Actual) then null; -- can be anything - elsif (Is_Dynamically_Tagged (Actual)) then + elsif Is_Dynamically_Tagged (Actual) then null; -- valid parameter elsif Is_Tag_Indeterminate (Actual) then @@ -437,8 +437,9 @@ package body Sem_Disp is -- inherited private subprograms are treated as dispatching, even -- if the associated tagged type is already frozen. - Has_Dispatching_Parent := Present (Alias (Subp)) - and then Is_Dispatching_Operation (Alias (Subp)); + Has_Dispatching_Parent := + Present (Alias (Subp)) + and then Is_Dispatching_Operation (Alias (Subp)); if No (Tagged_Type) then return; @@ -487,7 +488,7 @@ package body Sem_Disp is then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); - Decl_Item : Node_Id := Next (Parent (Tagged_Type)); + Decl_Item : Node_Id := Next (Parent (Tagged_Type)); begin -- ??? The checks here for whether the type has been @@ -537,7 +538,7 @@ package body Sem_Disp is elsif Is_Frozen (Subp) then - -- the subprogram body declares a primitive operation. + -- The subprogram body declares a primitive operation. -- if the subprogram is already frozen, we must update -- its dispatching information explicitly here. The -- information is taken from the overridden subprogram. @@ -595,7 +596,7 @@ package body Sem_Disp is if Present (Old_Subp) then Check_Subtype_Conformant (Subp, Old_Subp); Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); - + Set_Is_Overriding_Operation (Subp); else Add_Dispatching_Operation (Tagged_Type, Subp); end if; @@ -612,7 +613,7 @@ package body Sem_Disp is or else Chars (Subp) = Name_Finalize) then declare - F_Node : Node_Id := Freeze_Node (Tagged_Type); + F_Node : constant Node_Id := Freeze_Node (Tagged_Type); Decl : Node_Id; Old_P : Entity_Id; Old_Bod : Node_Id; @@ -623,19 +624,19 @@ package body Sem_Disp is Name_Adjust, Name_Finalize); - D_Names : constant array (1 .. 3) of Name_Id := - (Name_uDeep_Initialize, - Name_uDeep_Adjust, - Name_uDeep_Finalize); + D_Names : constant array (1 .. 3) of TSS_Name_Type := + (TSS_Deep_Initialize, + TSS_Deep_Adjust, + TSS_Deep_Finalize); begin -- Remove previous controlled function, which was constructed -- and analyzed when the type was frozen. This requires - -- removing the body of the redefined primitive, as well as its - -- specification if needed (there is no spec created for + -- removing the body of the redefined primitive, as well as + -- its specification if needed (there is no spec created for -- Deep_Initialize, see exp_ch3.adb). We must also dismantle - -- the exception information that may have been generated for it - -- when zero-cost is enabled. + -- the exception information that may have been generated for + -- it when front end zero-cost tables are enabled. for J in D_Names'Range loop Old_P := TSS (Tagged_Type, D_Names (J)); @@ -654,7 +655,7 @@ package body Sem_Disp is Old_Spec := Corresponding_Spec (Old_Bod); Set_Has_Completion (Old_Spec, False); - if Exception_Mechanism = Front_End_ZCX then + if Exception_Mechanism = Front_End_ZCX_Exceptions then Set_Has_Subprogram_Descriptor (Old_Spec, False); Set_Handler_Records (Old_Spec, No_List); Set_Is_Eliminated (Old_Spec); @@ -772,10 +773,9 @@ package body Sem_Disp is Next_Elmt (Op2); end loop; - -- Operation is a new primitive. + -- Operation is a new primitive Append_Elmt (Subp, New_Prim); - end Check_Operation_From_Incomplete_Type; --------------------------------------- @@ -800,6 +800,35 @@ package body Sem_Disp is -- dispatching attributes here. if not Is_Dispatching_Operation (Old_Subp) then + + -- If the untagged type has no discriminants, and the full + -- view is constrained, there will be a spurious mismatch + -- of subtypes on the controlling arguments, because the tagged + -- type is the internal base type introduced in the derivation. + -- Use the original type to verify conformance, rather than the + -- base type. + + if not Comes_From_Source (Tagged_Type) + and then Has_Discriminants (Tagged_Type) + then + declare + Formal : Entity_Id; + begin + Formal := First_Formal (Old_Subp); + while Present (Formal) loop + if Tagged_Type = Base_Type (Etype (Formal)) then + Tagged_Type := Etype (Formal); + end if; + + Next_Formal (Formal); + end loop; + end; + + if Tagged_Type = Base_Type (Etype (Old_Subp)) then + Tagged_Type := Etype (Old_Subp); + end if; + end if; + Check_Controlling_Formals (Tagged_Type, Old_Subp); Set_Is_Dispatching_Operation (Old_Subp, True); Set_DT_Position (Old_Subp, No_Uint); @@ -816,6 +845,7 @@ package body Sem_Disp is Set_Alias (Old_Subp, Alias (Subp)); -- The derived subprogram should inherit the abstractness + -- of the parent subprogram (except in the case of a function -- returning the type). This sets the abstractness properly -- for cases where a private extension may have inherited @@ -853,7 +883,11 @@ package body Sem_Disp is -- Normal case - elsif Is_Controlling_Actual (N) then + elsif Is_Controlling_Actual (N) + or else + (Nkind (Parent (N)) = N_Qualified_Expression + and then Is_Controlling_Actual (Parent (N))) + then Typ := Etype (N); if Is_Access_Type (Typ) then @@ -880,7 +914,12 @@ package body Sem_Disp is end if; end if; - if Is_Class_Wide_Type (Typ) then + if Is_Class_Wide_Type (Typ) + or else + (Nkind (Parent (N)) = N_Qualified_Expression + and then Is_Access_Type (Etype (N)) + and then Is_Class_Wide_Type (Designated_Type (Etype (N)))) + then return N; end if; end if; @@ -953,6 +992,12 @@ package body Sem_Disp is if not Has_Controlling_Result (Nam) then return False; + -- An explicit dereference means that the call has already been + -- expanded and there is no tag to propagate. + + elsif Nkind (N) = N_Explicit_Dereference then + return False; + -- If there are no actuals, the call is tag-indeterminate elsif No (Parameter_Associations (Orig_Node)) then @@ -992,7 +1037,7 @@ package body Sem_Disp is Prev_Op : Entity_Id; New_Op : Entity_Id) is - Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type)); + Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type)); begin -- Patch the primitive operation list |
